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Maintenance  Manual  for  AUDIT,  a System  for  Analyzing 
SESCOMP  Software,  Volume  1 

Maintenance  Manual  for  AUDIT,  a System  for  Analyzing 
SESCOMP  Software,  Volume  2;  Appendix  B - Listings  of 
the  AUDIT  Software  for  the  CDC  6000 

Maintenance  Manual  for  AUDIT,  a System  for  Analyzing 
SESCOMP  Software,  Volume  3;  Appendix  C - Listings  of 
the  AUDIT  Software  for  the  UNIVAC  1108 


Maintenance  Manual  for  AUDIT,  a System  for  Analyzing 
SESCOMP  Software,  Volume  4;  Appendix  D - Listings  of 
the  AUDIT  Software  for  the  IBM  360 


Volume  1 describes  AUDIT  and  the  use  and  maintenance  of  the 
AUDIT  software.  The  other  three  volumes  offer  software 
listings  for  the  CDC  6000,  UNIVAC  1108,  and  IBM  360. 
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AUDIT  Main  Program 


1 


PitOGRAH  M*IN( I NPUT«65, OUTPUT •6S,TkPES«IHRUT,T»l>E6«OUTPUT, 

HAIN 

3 

• T*PE7=:6S.T«PE8<69.T«PE9*G13,T«PEii=S13.T«Pet9>M3l 

MAIN 

% 

C»»*»IF  UMI»*C  U#8  - PLACE  * “C“  IM  COLUHM  1 OE  PREVIOUS  THO  CAROS 

MAIN 

9 

CONMON  A«13Z6I  tO(5aai.IOTBL<8<S08l<INITtO<3l  ,LASTIO«3)  ,ISRCH(3I, 

RICH 

Z 

* JPTR.N.N,  JTTP.LSTART.  NZ,  IFNCNH.LOeiO.NRTIOt  lOTTP.NIO.LOC. 

CY9  8A 

69 

Z LTTP.ITTPtlBLKOT.MOOE.IERR.IOES 

RICH 

k 

OINENSION  lOROClSI 

MAIN 

7 

COHHON/GLOBAL  /N8LK.NREF,  NSUBS.BLKTBL  1 Z08  NEXTTBL  « IBS  > t ISUBS(  lOSI 

MAIN 

6 

CONHON/INPOUT/NCALL.  IN.IOP 

MAIN 

9 

COHHON/LABELS/STATRA (Z. ZOO t. NL ABEL 

MAIN 

10 

CO NN ON/LIST /NL  1ST, NIHTFC>ISUBLT(Z. ZOO  • .INTFACI  3001 

MAIN 

11 

CONHON/OOLOOP/ISTACXU.50)  ,NSTACK,IL00P,  tOVFlH 

MAIN 

12 

COHNON/BASBLK/IBLOCKIZSOOl  ,NBLOCK,NB.NBRNCH 

CY5AA 

1 

COHHON/FLOH/IFL.IRP 

MAIN 

IN 

CONHON/STFUNC/NSTFNCatSTFNCdOl 

MAIN 

19 

INTEGER  A,BLANR,STATRA.BLKTBL,EXTTBL 

MAIN 

16 

DATA  BLANK/114  / 

MAIN 

17 

REMIND  A 

MAIN 

16 

REMIND  19 

MAIN 

19 

REMIND  7 

MAIN 

26 

REMIND  8 

MAIN 

21 

REMIND  9 

MAIN 

22 

DATA  IORO/Z9.30,31,3Z,ZS,Z8.  19,Z0.Z1.ZZ,  Z3.ZA.  Z6.Z7.3S/ 

MAIN 

23 

iop*e 

MAIN 

2N 

C»»REAO  INPUT  PARAMETERS 

main 

29 

C*»HOOE  - NODE  OF  OPERATION 

MAIN 

26 

C»»IN  - INPUT  FILE 

MAIN 

27 

C»»IFL  - flom  analtsis  parameter 

MAIN 

26 

C»*INTR  - INTRINSIC  FUNCTION  PARAMETER 

MAIN 

29 

REAOIS.'lZ*  NODE.IN.IFL.INTR 

MAIN 

30 

IZ  FORNATII1.3IAI 

MAIN 

31 

NCALL«0 

MAIN 

32 

NREF*0 

MAIN 

33 

NBLK'O 

MAIN 

SN 

NSUBS'G 

MAIN 

39 

IRP*IFL-1 

MAIN 

36 

C»»  READ  SESCONP  LIST 

MAIN 

37 

REAOIAt  NLIST.NINTFC 

MAIN 

^6 

RE  ADI  A)  IIISUBLT  II,J),I>1,Z)  .J'l.NLlST) 

MAIN 

39 

REAOIAI  IINTFACII»,I>1,NINTFCI 

MAIN 

NO 

A ISTAT>0 

MAIN 

N1 

IOVFLM>0 

MAIN 

N2 

NLABEL*0 

MAI  N 

N3 

NID>0 

MAIN 

NN 

JJ>8 

MAIN 

N9 

IBLKOT«0 

MAIN 

N6 

NSTACK<0 

main 

N7 

NBLOCK'O 

MAIN 

N6 

ILOOP«0 

MAIN 

N9 

NB«0 

MAIN 

96 

IBLKST>0 

MAIN 

91 

NSTFNC*0 

MAIN 

92 

NRITE(6,13) 

MAI  N 

93 

1 3 FORMAT (IHII 

MAIN 

9N 

IFNCNN^BLANK 

MAIN 

99 

DO  Z I*l,8 

MAIN 

96 

DO  Z J>1,500 

MAIN 

97 

Z lOTBLd.JI'l 

MAIN 

58 

DO  3 I>1,Z0I 

MAIN 

59 

ST*TR*I1,I*>I 

MAIN 

60 

3 ST«TR*(Z,II>1 

MAIN 

61 

00  S I«l,3 

MAIN 

6Z 

INITtOlIMO 

MAI  N 

63 

S LASTIDIIKO 

MAIN 

64 

roa  CONTINUE 

MAIN 

65 

IFINBLKK  .GT.  ZSOOl  GO  TO  7000 

MAIN 

66 

• RE»Q  NEXT  STRTEHENT 

MAIN 

67 

CALL  BUILO 

MAIN 

68 

* WRITE  OUT  NEXT  STATEHENT 

MAIN 

69 

WRITE(6.  10001  (Itllfl-l.NI 

MAIN 

70 

000  EORN«TI//6X,100«1.13t/£X,100*lM 

MAIN 

71 

* SKIP  IF  COMHENT  OR  BLANK  CARO 

MAIN 

7Z 

IFIAin  ,EQ.  IHCI  GO  TO  700 

MAIN 

73 

IF«NEXT(1I  .EQ.  BLANKI  GO  TO  700 

MAIN 

74 

MAIN 

75 

• ClASSIFT  STATEMENT 

MAIN 

76 

CALL  CLASS 

MAIN 

77 

IFIITTP  .GT.  10  .and.  ITVP  .NE.  ZS»  GO  TO  13Z0 

MAIN 

78 

call  STATNO 

MAIN 

79 

3Z0  JPTR*7 

MAIN 

80 

IPREC«ISTAT 

MAIN 

81 

ISTAT»ITYP 

MAIN 

8Z 

IF(JJ  .EO.  11  GO  TO  7 

MAIN 

83 

IFIIBLKOT  .EQ.  0 1 GO  TO  6 

MAIN 

84 

IFdTTP  .GE.  10  .AND.  ITTP  .LE.  Z7I  GO  TO  0 

MAIN 

85 

GO  TO  ZZO 

MAIN 

86 

6 IF»LTYP  .EQ.  91  GO  TO  IZO 

MAIN 

87 

GO  TO  0 

MAIN 

88 

7 IF«ITYP  .LT.  Z9  .OR.  ITYP  .GT.  3Z»  CALL  EBRORI  Zl 

MAIN 

89 

0 GO  TO  I60.70.09.90.100.110.Z0.1AO.ZO.ZO<AO.AO,50  , 90,50.1Z0.130. 

MAIN 

90 

1 Z000.10.10.10.10.10.170.100.190.z0t.zi0  .190. 30.  30. 160. ZZO.  ZZO. 

MAIN 

91 

Z ZZO, ZZO). ITTP 

MAIN 

9Z 

10  00  15  I'l.ll 

MAIN 

93 

IFdPREC  .EO.  lOROdll  GO  TO  17 

MAIN 

94 

15  continue 

MAIN 

95 

• GO  TO  APPROPRIATE  STATEMENT  PROCESSOR 

MAIN 

96 

CALL  ERROR(ZI 

MAIN 

97 

17  CALL  TYPE 

MAIN 

98 

GO  TO  500 

MAIN 

99 

ZO  CALL  SIMP 

MAIN 

188 

GO  TO  500 

MAIN 

101 

30  IFtJJ  .NE.  11  CALL  ERRORIZI 

MAIN 

lOZ 

00  35  I>1,Z0 

MAIN 

103 

IFtNEXMJPTR)  .ME.  IMF)  GO  TO  35 

MAIN 

104 

JPTR»JPTR-1 

MAIN 

105 

CALL  SUB 

MAIN 

186 

CO  TO  500 

MAIN 

107 

35  CONTINUE 

MAIN 

108 

38  IFIJJ  .NE.  1)  CALL  ERROR(Z) 

MAIN 

109 

CALL  SUB 

MAIN 

lit 

GO  TO  500 

MAIN 

111 

40  CALL  10 

MAIN 

IIZ 

GO  TO  500 

MAIN 

113 

50  call  AUXIO 

MAIN 

114 

GO  TO  500 

MAIN 

115 

60 

CALL  INIT 

MAIN 

116 

N9ITFI6.66)  (AfIltI«l,NI 

MAIN 

117 

IFlITyP  ,NF.  35»  GO  TO  500 

MAIN 

118 

ISTAT»35 

MAIN 

119 

00  67  1*1,15 

MAIN 

120 

IFCIPREC  ,EO.  lOROlIM  CO  TO 

500 

MAIN 

121 

67 

CONTINUE 

MAI  N 

122 

CALL  ERR0R(7I 

MAIN 

123 

GO  TO  500 

MAIN 

126 

70 

CALL  ASSIGN 

MAIN 

125 

GO  TO  500 

MAIN 

126 

80 

CALL  GOTO 

MAIN 

127 

GO  TO  500 

MAIN 

128 

90 

CALL  ASGOTO 

MAIN 

129 

GO  TO  500 

MAIN 

131 

10  0 

CALL  CTGOTO 

MAIN 

131 

GO  TO  500 

MAIN 

132 

110 

CALL  ARIF 

MAIN 

133 

CO  TO  500 

MAIN 

136 

1?0 

CALL  LXIF 

MAIN 

135 

GO  TO  500 

MAIN 

136 

130 

CALL  DO 

MAIN 

137 

GO  TO  500 

MAIN 

138 

16  0 

call  call 

MAIN 

139 

WRITE(b,66)  (Adltl-ltN* 

MAI  N 

160 

66 

FORMAT (6X,72A1I 

MAIN 

161 

GO  TO  500 

MAIN 

162 

150 

IFfJJ  ,NE.  n call  ERR0R(2> 

MAIN 

163 

IBLKOT«l 

MAIN 

166 

CALL  SIMP 

MAI  N 

165 

GO  TO  500 

MAIN 

166 

160 

IFfJJ  ,NE.  1»  CALL  ERRORI2) 

MAIN 

167 

CALL  PROG 

MAIN 

160 

GO  TO  500 

MAIN 

169 

17  0 

00  175  I*ltl? 

MAIN 

150 

IFdPREC  .EQ.  lORDdM  GO  TO 

177 

MAIN 

151 

175 

CONTINUE 

MAIN 

152 

CALL  ERRORdI 

MAIN 

153 

177 

CALL  OIHEN 

MAIN 

156 

GO  TO  500 

MAIN 

155 

180 

00  185  I«l«5 

MAIN 

156 

IFCIPREC  «E0.  lOROdM  GO  TO 

187 

MAIN 

157 

185 

CONTINUE 

MAIN 

150 

CALL  ERRORI21 

MAIN 

159 

187 

CALL  COM 

MAIN 

168 

GO  TO  500 

MAIN 

161 

190 

00  195  I«l«13 

MAIN 

162 

IFdPREC  ,EQ.  lOROdll  60  TO 

197 

MAIN 

163 

195 

CONTINUE 

MAIN 

166 

CALL  ERRORf?» 

MAIN 

165 

197 

CALL  EOUIV 

MAIN 

166 

GO  TO  500 

MAIN 

167 

^to 

DO  205  I«l»16 

MAIN 

168 

IFdPREC  •EO.  lOROdM  GO  TO 

207 

MAIN 

169 

705 

CONTINUE 

MAIN 

170 

CALL  ERROR(2> 

MAIN 

171 

C«u  DATA 
GO  TO  SOO 
00  2\S  I«l»6 

IFlIPRfC  .FQ.  lOROtn*  GO  TO  ?17 

CONTiNUe 

CALL  e^OORI?! 

IMN  .CT.  731  GO  TO  ?%0 
WRITE(I0P«?1SI  lAnitlst.NI 
FORMAT (7?A1 I 
GO  TO  350 

MRITF(IOP*3<>SI  IAin,I«l,NI 

FORMAT (7  3A1/ISX»1M«,66A1 I I 

CALL  FRMAT 

GO  TO  700 

CALL  FRPORin 

CONTINUF 

IF  (N  .GT.  73)  GO  TO  9i»0 
MRXTEUOR«S30I  tAin,I«l,NI 
FORMAT  f73Al) 

GO  TO  600 

MR  HE  I I0P.S6S)  (Am»I«l,N) 

FORMAT (73Al/fSV,lH*,66Al> ) 

IFtHOOE  .ME.  1 I GO  TO  710 

IFfITTP  .LT,  30  .OR.  ITYP  .GT.  331  GO  TO  700 
MRITE I IOP«610I 

FORMAT (9X,19H  COMPLEX  QICOMPI 
NRITEIIOP.630) 

FORMAT fSX.34H  DOUBLE  PRECISION  QIOPREI 

GO  TO  700 

MRrTETrOP,3030) 

FORMAT  <6X,3MENOt 

IF(N  .me.  73)  WRITE(6,3100> 

FORMAT (6X»33H  ILLEGAL  ENO  STATEMENT! 

CALL  SUeCHK 

IFflNTR  .NE.  1>  GO  TO  3205 
CALL  IMTRIN 
ISPLAY  SYMBOL  TABLE 
CALL  SYMTAB 
CALL  GRT 
CALL  COMCHK 

IFdOVFLM  .EQ.  1)  GO  TO  3310 
CALL  LOOPCK 

IFdFL  .EQ.  0 .OR.  IBLKOT  .EQ.  II  GO  TO  3310 
CALL  FLOHCX 

IF  dERR  .ME.  31  GO  TO  h 
CALL  GLOTAB 

IFCMOOE  .EQ.  II  GO  TO  6000 

CALL  GENROL 

REMIND  B 

REMIND  S 

STOP 

MRITE(6t700Bl 

FORMAT </////SX»SAH  OVERFLOM  OF  BASIC  BLOCK  TABLE 
•INATEDI 


S 

E 


MAIN 
MAIN 
MAI  N 
MAIN 
MAIN 
MAIN 
MAI  N 
MAIN 
MAIN 
MAIN 
MAIN 
MAI  N 
MAIN 
MAIN 
MAIN 
MAIN 
MM» 
MAi  k 

maim 

MAIN 
MAIN 
MAIN 
MAIN 
MAIN 
MAIN 
MAIN 
MAIN 
MAIN 
MAIN 
MAIN 
MAIN 
MAIN 
MAIN 
MAIN 
MAIN 
MAIN 
MAIN 
MAIN 
MAIN 
MAIN 
MAIN 
MAIN 
MAI  N 
MAIN 
MAIN 
MAIN 
MAIN 
MAIN 
MAIN 
MAIN 
MAIN 
MAIN 

PROCESSING  TERM  MAIN 


AUDIT  Subprograms 


SURROUTINE  I F 

ARIF 

2 

COHHON  A(1326}«O<500)«IOTBL<8,S00)«INlTlon)«LASTIOf3l,  ISRCH(3>« 

RICH 

2 

• JPTRfN,H, JTYP ,L START, N2, IFNC NH,L OGI 0 , NK TIO, ID  TYP,NIO,LOC, 

CY5  6A 

SO 

2 LTYP,ITYP,I0L  KOT,MOOE,IERR,  lOES 

RICH 

A 

COMHON/TY P/NO 0,RH STY  P, NQ2 , NQ3 . L HSTVP 

ARIF 

4 

C0MH0N/STRING/NTYPE,NSTR,STR (500) 

APIF 

5 

COHMON/LABELS/STATRA(?,20  0),NLAeEL 

ARIF 

6 

COHNON/BA$BLX/IBLOCK(2500) , NBl OCK ,NB ,N BR NCH 

CY5  8A 

32 

INTEGER  A,STATRA,STR,C0MMA,8LAN»(,RHSTYP,  AY,EF 

ARIF 

S 

INTEGER  BITPUT 

API  f 

9 

DATA  LPAR/1H(/,C0HMA/1H,/,BCAN</1H  /,  A Y/ 1H  1/ ,E  F/ IMF/ 

ARIF 

10 

c** 

arithmetic  if  STATEHENT  PROCESSOR 

ARIF 

11 

IF(NEXT(JPTRI  .NE,  AY)  GO  TO  20 

ARIF 

12 

IFCNEXK  JPTR)  .NE.  EF)  GO  TO  20 

ARIF 

13 

IF(NEXT( JPTRI  .NE.  LPAR)  GO  TO  20 

ARIF 

14 

JPTRsJPTR-1 

ARIF 

15 

c** 

PARSE  THE  EXPRESSION 

ARIF 

16 

CALL  EXPR 

ARIF 

17 

NSTR=NSTR>1 

ARIF 

IS 

STRINSTRI*  -5 

ARIF 

19 

NTYPE=1 

ARIF 

20 

CALL  PARSE 

APIF 

21 

PROCESS  FUNCTION  REFERENCES 

ARIF 

22 

CALL  FNCSTR 

ARIF 

23 

IF(RHSTYP  ,EQ.  1)  CALL  ERRORCA2) 

ARIF 

24 

STORE  BASIC  BLOCKS 

ARIF 

25 

CALL  0LKSTR 

ARIF 

26 

NBRNCHcQ 

ARIF 

2? 

00  10  1=1,3 

APIF 

20 

C** 

GET  NEXT  BRANCH 

ARIF 

29 

CALL  GNLE 

ARIF 

30 

IFCJTYP  .NE.  5)  GO  TO  20 

APIF 

31 

c** 

GET  STATEMENT  NUMBER  TABLE  LOCATION  ANO  SET  -REFERENCED*  FLAG 

APIF 

32 

CALL  STSRCH 

APIF 

33 

STATRA (2, LOO  * BIT  PUT f STATRA ( 2,  LOC 1 ,1,  l2) 

ARIF 

34 

IF(  NBPNCH  .EQ.  0)  GO  TO  5 

ARIF 

35 

c** 

CHECK  FOR  DUPLICATE  BRANCHES 

ARIF 

36 

DO  3 J=1,NBRNCH 

ARIF 

37 

IFCLOC  «EQ.  IBLOCKINBLOCK-J^l ) > GO  TO  7 

APIF 

36 

3 continue 

ARIF 

39 

c** 

STORE  BRANCH  IN  BASIC  BLOCK  TABLE 

ARIF 

40 

5 N0LOCK=NBLOCK^1 

ARIF 

41 

IBLOCKfNBLOCK ) «LOC 

APIF 

42 

c** 

INCREMENT  BRANCH  COUNTER 

ARIF 

43 

NeRNCHsNSRNCH41 

ARIF 

44 

7 IF(I  «EO.  3)  GO  TO  10 

ARIF 

45 

IF  (NEXT(JPTR)  .NE.  COMMA)  GO  TO  20 

ARIF 

46 

10  CONTINUE 

ARIF 

47 

IF (NEXT ( JPTR)  .NE.  BLANK)  GO  TO  20 

ARIF 

4S 

NB«1 

ARIF 

49 

return 

ARIF 

50 

20  CALL  ERROR!?) 

ARI  F 

51 

return 

ARIF 

52 

END 

API  F 

53 

V 
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SUBROUTINE  ASGOTO 

COHHON  A 113361  « D ( 5Q0 1 1 IOTBL < 8 « 500 1 , IN ITI 01 3) »L ASTIOC 31 • ISRCH< 3 1 • 
* JPTR«N,H, JTTP,LSTART«N3, IFNCNN«L OGIO • NX TIOt 10  TYP«NIO«LOCt 
2 LTYPflTYPtlBLROT.HOOEtieRRflOES 
CONHON/LAeELS/STATRAI?,200l«NLAeEt 
COHHON/BASBLK/ IBLOCK(350Q) «NBLOCK .MBtHBRNCH 
DIMENSION  IALPHC6I 
INTEGER  STATRAfBLANKtCOHHA.RPAR.A 
INTEGER  BITPUTfBITGET 

OATA  CIALPHm  ,Islt«»l/lHG*lHOtlHT«lHO/ 

DATA  BLANK/IH  /« COHMA/IH « / «LPAR/ IH I /•  RPA R/IH )/ 

ASSIGNED  GO  TO  STATEMENT  PROCESSOR 
[ 00  5 I«lf«» 

IFINEXTf JPTRI  «NE«  lAtPHflU  GO  TO  30 
i 5 CONTINUE 

I C**  GET  VARIABLE  REFERENCE 

CALL  GNLE 

IFUTYP  .NE*  31  GO  TO  30 
C**  GET  SYMBOL  TABLE  LOCATION 
CALL  SEARCH 

IFCISRCH<3)  .EQ.  1)  CALL  ERROR <10 tNXT lOI 
IFdSRCHfll  •EQ«  II  GO  TO  10 
lOTYP*! 

CALL  STORE 
LOC*NID 

C»*  GET  TYPE  AND  CHECK  THAT  IT  IS  INTEGER  VARIABLE 
10  CALL  IM’TYP 

IF<BITGET(I0TBL<3«L0CI  fl0,3)  .NE*  61  CALL  ERROR! 35 «NXT  lOI 
IF (BITGETCIOTBL (3«L0CI «lf II  •EQ.  1)  CALL  ERROR <1 6, NXT lOI 
IFINEXTIJPTR)  «NE«  COMMAI  GO  TO  30 
IF  INEXT < JPTRI  .NE*  LPARI  GO  TO  30 
C**  STORE  REFERENCE  IN  BASIC  BLOCK  TABLE 
NBLOCK«NBLOCX»l 
IBLOCK (NBLOCKI  s5000«LOC 
NBRNCH>0 

C»*  GET  NEXT  BRANCH 
30  CALL  GNLE 

IFIJTVP  .NE*  51  GO  TO  30 

C**  GET  STATEMENT  NUMBER  TABLE  LXATION  AND  SET  -GOTO“  FLAG 
CALL  STSRCH 

STATRA  (3«LOC»  *BI TPUTCSTATRAf 3. LOCI.lt 131 
IFINBRNCH  .EQ.  0>  GO  TO  35 
C**  CHECK  FOR  DUPLICATE  BRANCHES 
00  33  I*l*NBRNCH 

IFILOC  «EQ*  I3L0CK<NBL0CK-I^U  » GO  TO  3T 
33  CONTINUE 

C**  STORE  BRANCH  IN  BASIC  BLOCK  TABLE 
35  NBLOCKsNBLOCK^l 

IBLOCK < NBLOCKI  »LOC 
C**  INCREMENT  BRANCH  COUNTER 
NBRNCH«NBRNCHfl 

37  IFfNEXTf JPTRI  .EQ.  COHHAI  GO  TO  30 
IF(AUPTR-H  «NE«  RPARI  GO  TO  30 
IF  (NEXT  < JPTRI  «NE«  BLANKI  GO  TO  30 
NB«1 
return 

30  CALL  ERR0R(7I 
return 

END 
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6 
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6 
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6 
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7 
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6 

ASGOTO 
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11 
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16 

ASGOTO 

15 

ASGOTO 

16 

ASGOTO 

17 

ASGOTO 

18 

ASGOTO 

19 

ASGOTO 

30 

ASGOTO 

31 

ASGOTO 

33 

ASGOTO 

33 

ASGOTO 

36 

ASGOTO 

35 

ASGOTO 

36 

ASGOTO 

37 

ASGOTO 

38 

ASGOTO 

39 

ASGOTO 

30 

ASGOTO 

31 

ASGOTO 

33 

ASGOTO 

33 

ASGOTO 

36 

ASGOTO 

35 

ASGOTO 

36 

ASGOTO 

37 

ASGOTO 

38 

ASGOTO 

39 

ASGOTO 

60 

ASGOTO 

61 

ASGOTO 

63 

ASGOTO 

63 

ASGOTO 

66 

ASGOTO 

65 
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66 
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SUBftOUTtNE  ASSIGN 

ASSIGN 

3 

COHHON  A(13?6)«OISOO),IOTBL(6.500I«INITIOI3)«LASTIO<S>, ISRCHI3I* 

RICH 

3 

• JPTR*NtHtJTVP«L START »N3, IFNCNH,LOGIOf NV TIO, ID TY P, Nt 0* lOC t 

CY58A 

80 

2 LTYP.ITrP,I8LR0T,N00CtIERR»I0eS 

RICH 

4 

COHNON/LABELS/STATRAf?«?00)«NLABEL 

ASSIGN 

4 

COMNON/BASBU/IBLOCK<?60  0I  *NBL0CK,NB«NBRNCH 

CY58A 

30 

OIHENSION  IALPHI6I 

ASSIGN 

6 

INTEGER  6LA»«(,TEE*0H,STATRA 

ASSIGN 

7 

INTEGER  BITPUTfBITGET 

ASSIGN 

8 

DATA  BLANK/IM  /*TEE/1HT/.OH/1MO/ 

ASSIGN 

9 

DATA  (lALPHdl  • I » 1 «6  1 /IH A , 1HS«  IHS*  IHI  t IH  G«  IHN/ 

ASSIGN 

10 

c** 

ASSIGN  STATEMENT  PROCESSOR 

ASSIGN 

11 

00  S Isl«6 

ASSIGN 

13 

IFCNEVTf  JPTRI  «NE«  lALPHCH)  GO  TO  20 

ASSIGN 

13 

S CONTINUE 

ASSIGN 

14 

c** 

GET  STATEMENT  LABEL 

ASSIGN 

15 

CALL  GNLE 

ASS  ION 

16 

IFCJTYP  ,NE.  51  GO  TO  20 

ASSIGN 

IT 

SEARCH  STATEMENT  NUMBER  TABLE 

ASS  IGN 

18 

CALL  STSrCH 

assign 

19 

C** 

SET  -ASSIGN-  FLAG 

ASSIGN 

30 

STATRA  l?,LOC>  =BI TPUT ISTATRA(?,L0C)«1«13) 

ASSIGN 

31 

IF  (NEXT  < JPTRl  .HE.  TEE  > GOTO  20 

ASSIGN 

33 

IFfNEXTl JPTR)  .NE«  0H|  CO  TO  30 

ASSIGN 

33 

c** 

GET  variable  RFFERENCE 

ASSIGN 

34 

call  gnle 

ASSIGN 

35 

TFCJTYP  ,NE«  31  GO  TO  30 

ASSIGN 

36 

c** 

GET  SYMBOL  T AflL  E • L OCA  T I ON 

ASSIGN 

27 

CALL  SEARCH 

ASSIGN 

38 

IF(ISRCHC3)  .FQ«  U CALL  ERROR  ( 1 0 .NX  T 10) 

ASSIGN 

39 

IFlISRCHd)  .EQ.  It  GO  TO  10 

ASS  IGN 

30 

lOTYPsl 

ASSIGN 

31 

CALL  STORE 

ASSIGN 

33 

LOC=NIO 

ASS IGN 

33 

c** 

CHECK  THAT  IT  IS  AN  INTEGER  VARIABLE 

ASSIGN 

34 

10  call  imptyp 

ASS  IGN 

35 

IF ceiTGET (I0TBLI3,L0C) «10 • 3)  .NE.  4t  CALL  E PRO R( 39, NXT 10 t 

ASS IGN 

36 

IF (RITGET (IOTBL f 3,L0Ct ,1 t It  ,EQ,  It  CALL  E RROR f 1 4 , NX T 1 Ot 

ASS  ir.N 

3T 

IF  CNEXTI JPTR)  ,NE.  BLANK)  GO  TO  30 

ASS IGN 

36 

c** 

STORE  ASSIGNED  VARIABLE  IN  BASIC  BLOCK  TABLE 

ASS  IGN 

39 

NBLOCK^NBLOCK*! 

ASS  IGN 

40 

IflLOCKINBLOCKt  =4000»LOC 

ASSIGN 

41 

RE  TURN 

ASSIGN 

43 

30  CALL  ERRORirt 

ASSIGN 

43 

RETURN 

ASSIGN 

44 

ENO 

ASSIGN 

45 

SUBROUTINE  AUKIO 

COHHON  A (13?6), 0(5001  tIOTBL(8|SOO),INlTIO(3l t L AS T 1 0 ( 1 ) f ISRCH ( 3 > « 
• JPTR.N.H, JTYP,L START *N2, IFNCNH.LOGIO, NX TIO*  10  TYP,NlO*LOCt 
2 LTYP* ITYP, IBLK0T,H00E  * lERR, lOPS 
COHMON/0ASBL< /I6LOCX(2500I •NBL Ot X ,NB «N BR NCH 
DIMENSION  lALPMl  (6)  , IALPH2I9)  • IALPM3  17  ) 

INTEGER  BITGFT 

DATA  (IALPHK  II  t I=lt6»  /I  HR  , IHE 1 1 HM,  IH  I , 1 HN  . I HO  / 

DATA  (IALPH2(  I) , I s 1 , 9) / 1 MB ,l MA , 1 HC, 1 HX , I HS • 1 HP  ,1 « A ,1 HC . IHE/ 

DATA  ( IALPH3(  1 1 * I = 1 , 71  /I  HE  *1  HN  , 1 HO  , IHE  ,l  HI  , 1 ML  tlHr/ 

€••  auxilary  I/O  STATEMENT  PROCESSOR 
IT=16-ITYP 
IE(IT-2I  25,15,5 
C**  REWIND  STATEMENT 
5 00  1C  1*1,6 

IE(NEXT(JPTR»  ,Nf.  lALPHldM  GO  TO  50 
10  CONTINUE 
GO  TO  60 

C**  BACXSPACE  STATEMENT 
15  00  20  1=1,9 

IF(NEXT(JPTR)  .NE.  IALPH2(III  GO  TO  50 
20  CONTINUE 
GO  TO  40 

C**  ENOEILE  STATEMENT 
25  00  30  1*1,7 

IE (NEXT ( JPTRI  ,NE,  IALPH3(III  GO  TO  50 
30  continue 

C**  GET  I/O  DEVICE  - MUST  BE  INTEGER  VARIABLE 
40  CALL  GNLE 

IEIJTYP  ,NE.  2)  GO  TO  60 
IF (NEXT ( JPTRI  ,NE,  IH  I GO  TO  50 
€••  STORE  IN  SYMBOL  TABLE 
CALL  SEARCH 

IE(ISRCH(2I  .EO.  II  CALL  ERROR ( 10 ,NXT lOI 

lEdSRCHdl  .EQ,  II  GO  TO  45 

lOTYPsl 

CALL  STORE 

LOC*NID 

C**  SET  TYPE  and  CHECX  THAT  IT  IS  INTEGER 
45  CALL  IMPTYP 

IE(6ITGET(I0TBL(3,L0CI  ,10,31  ,NE,  4)  CALL  ERROR(?2l 
IE  (BiTGETdOTBL  (3,LOCI  ,1, 1)  ,EO*  II  CALL  ERR  OR  (1 4,  NXT  1 01 
C»*  STORE  IN  BASIC  BLOCK  TABLE 
N8L0CX»NBL0CX^ 1 
IBLOCX (NBLOCKI  *2000«LOC 

return 

50  CALL  ERROR(7l 
RETURN 

60  CALL  ERROR(2?l 
RETURN 
END 
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4 

CY5SA 

12 

AUXIO 

5 

AUXIO 

6 

AUXIO 

7 

AUXIO 

8 

AUXIO 

9 

AUXIO 

10 

AUXIO 

11 

AUXIO 

12 

AUX  10 

13 

AUX  10 

14 

AUXIO 

IS 

AUXIO 

16 

AUX  10 

17 

AUX  10 

16 

AUX  10 

19 

AUXIO 

20 

AUXIO 

21 

AUXIO 

22 

AUXIO 

23 

AUXIO 

24 

AUXIO 

25 

AUXIO 

26 

AUXIO 

27 

AUXIO 

28 

AUXIO 

29 

AUXIO 

30 

AUXIO 

31 

AUXIO 

32 

AUXIO 

33 

AUXIO 

34 

AUX  10 

35 

AUXIO 

36 

AUX  10 

37 

AUXIO 

38 

AUXIO 

39 

AUXIO 

40 

AUXIO 

41 

AUXIO 

42 

AUXIO 

43 

AUXIO 

44 

AUXIO 

45 

AUXIO 

46 

AUXIO 

47 

AUXIO 

48 

AUXIO 

49 

AUXIO 

50 
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INTEGER  FUNCTION  0ITGE  T ( HOC  , IPOS  , INI  D TH  t BITGET 

OHCNSION  IM»SK(18»  BITGET 

0*T*  I INASK  II  » .1*1,181 /IB  fJB.TB,  ITS,  J7B.  778,1778  tSrrB.TTTB,  BITGET 

1 1777B,3  777B,  7777B, 177778, J7777B.77777B,  1777770,3777778,7777776/  BITGET 
BITGfT*SHIFT(IlOC,IPOS)  .AND.  IMA  SK  I IN  ID  THI  BITGET 

return  BITGET 

ENO  BITGET 


INTEGER  FUNCTION  BITPUTIILX,IVAL,IPOS» 
NSMIFT*G0-IPOS 

BITPUT-ILOC  .or.  SHIFTIIVAL.NSHIFTI 

RETURN 

ENO 


BIT  PUT 
BIT  PUT 
BITPUT 
BITPUT 
BIT  PUT 


I 


subroutine  bl<str 

COMHON  Af  13361  tO  (500)  « IOTBK  9« 500) « INI TiOm  «L  ASTI 0(3 1 .ISRCHO  I « 
• JPTR,N,N,jTrP,LSTART,N2,IFNCNH,L0GI0f NATIOt 10 TTP , NIO. LOG t 
2 LTYP* ITYP,iat KOT,MOOEt lERRf lOES 
C0HM0N/FUNC/IFNCRA(5tl2)  • H ARCS  « I ARCS  ( 5 0)  tFNCL0C(5)  «NFUNC 
COHMON/LIST/NLlST,NINTFCf ISUBLT ( 2 , 30 0 I . I NTFA C ( 300) 
COHMON/BASBLK/ieiOCK(2500) fNBLOCK»NBfNBRNCH 
INTEGER  0ITPUT,8ITGET,FNCLOC 

C**  THIS  routine  is  CALLED  AFTER  PARSING  AN  EXPRESSION,  TO  STORE 
INFORMATION  IN  THE  BASIC  BLOCK  TABLE 
IF(HARGS  .EQ.  01  RETURN 
00  100  Isl,HARGS 
I0STAT«2 

IC0L  = 2C*M00(I-1,3)  ♦lO 
IVR»(M2)/3 

C**  GET  symbol  table  LOCATION  OF  NEXT  VARIABLE  IN  THE  STATEMENT 
L0C«6ITGET (IARGS( IVR) , ICOL,10) 

NFNCsBiTGETlIARGSdVR)  ,ICOL*^3,  3) 

1F(NFNC  .EQ*  0)  GO  TO  60 

C**  variable  is  a function  ARGUMENT  - GET  SYMBOL  TABLE  LOCATION 
C»*  OF  FUNCTION 

ILOCsFNCLOC(NFNC) 

C**  GET  POSITION  OF  VARIABLE  IN  ARGUMENT  LIST 
NARG^BITGET (lARGS (IVR) , IC0L»B,6) 

C**  GET  SYMBOL  TABLE  LOCATION  OF  FUNCTION 
INDEX  = BIT  GET!  IOTBLO,  ILOC)  ,36,  B I 
IF (INDEX  .EQ*  0)  GO  TO  60 
C**  GET  interface  [>€FINITI0N  TABLE  POINTER 

IPTRs0ITGETCISU0LT(?,INOEX),6O ,15)f(NARG-1)/6 
JVAR=0ITGET  (ISUBIT(2,  INDEX  ) ,1«»,1) 

IC0L*9*M00 (NARG-1 ,61 49 
IF(JVAR  •£().  1)  IC0L»9 
C**  GET  I/O  status  of  ARGUMENT 

IOSTaT=BITGET ( INTFAC (IPTR) ,ICOL,3) 

KPTRz (NARG^ll ) /6 
IC0L2s56fIC0L/9 
C»*  SET  “EXPRESSION-  FLAG 

texpsbitcet(ifncra(nfnc,kptr» , I col  2,1) 

IFdOSTAT  .ED.  2)  GO  TO  60 
IF  IIEXP  .NE,  0)  GO  TO  40 
IFiroSTAT  .EO.  1 ) GO  TO  60 
GO  TO  60 

C**  ARGUMENT  APPEARS  IN  EXPRESSION  BUT  IS  NOT  DESIGNATED  "LOGICAL 
C»*  INPUT-  - MUST  BE  CLASS  0 FUNCTION 

C**  IF  CLASS  0 FUNCTION,  CHANGE  STATUS  TO  “LOGICAL  INPUT-  - 
C**  OTHERNISE  ISSUE  DIAGNOSTIC 

40  IF  leiTGET  ( ISUBLT  (2,IN0EX)  , 10 ,4)  .NE.  0)  GO  TO  90 
INTFAC (IPTR)sBITPUT(INTFAC (IPTR) ,2, ICOL) 
tOSTAT«2 

C**  variable  is  referenced  - STORE  IN  BASIC  BLOCK  TABLE 
60  NBLOCKsNBLOC<»l 

I8L0CK  (NBLOCK) S2000FLOC 
IFdOSTAT  ,ED.  2)  CO  TO  100 
C**  VARIABLE  IS  OEFINEO  - STORE  IN  BASIC  BLOCK  TABLE 
60  NBLOCK>NBLOCX^l 

IBLOCK  (NBLOCK) slOOO^LOC 
GO  TO  100 

90  CALL  ERROR(55,NARG) 

100  CONTINUE 
RETURN 
ENO 
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SUBROUT  INC  BUILD 

BUILD 

2 

CONHON  A I13?6»  • 0 f SOO  > * ID TBU  6*  *>0 0 U X NT T 1 0(  3 > «L  AS T 10 ( 3>  t ISRCH(3>t 

RICH 

2 

• JPTR, N,N*JTVR • L START, N?, ICNC NN , L OG 10 , NX TI 0, ID TYP , NI 0, LOC , 

CY5SA 

80 

2 LTYP, ITYP,I0LXOT,HOOC,ICRR,  iocs 

RICH 

k 

CONHON/I NPOUr/NCALL*IN,IOP 

BUILD 

k 

intcgcr  a, b, blank 

BUILD 

5 

COHNON/MASTC/B (7?I 

BUILD 

6 

c**  This  routine  reads  in  the  ncxt  statcmcnt 

BUILD 

7 

DATA  BLANK/IH  /,ICC/1MC/ 

build 

6 

ICRRrO 

BUILD 

9 

NFIRST*! 

BUILD 

10 

NCONTU^O 

build 

11 

NCALL»NCALL^I 

BUILD 

12 

so  CONTINUC 

BUILD 

13 

IF<NFIRST  .CQ,  1 .AND,  NCALL  • NC • U GO  TO  1 

BUILD 

1% 

READ  NEXT  CARO 

build 

15 

READUNtlOO)  IB(n,I«l,7ZI 

build 

16 

IMEOE  (IN»  .NE.  0)  GO  TO  10 

BUILO 

17 

too  F0RHAT(7?A1) 

BUILD 

18 

1 CONTINUE 

build 

19 

IFfNFIRST  .CO.  n GO  TO  3 

BUILO 

20 

IF(B(i)  .CQ.  ICC)  GO  TO  9 

BUILO 

21 

IFIB(6)  .NE.  blank  .ANO.  B (6 ) »NC.  IHQ)  GO  T 0 6 

BUILD 

22 

GO  TO  9 

BUILO 

23 

2 CONTINUE 

BUILO 

2^ 

C**  STORE  FIRST  72  COLUHNS 

BUILD 

25 

II 

o 

o 

BUILO 

26 

AmsBiii 

BUILO 

27 

3 CONTINUE 

BUILD 

28 

NF IRST»0 

BUILO 

29 

NCNAR*72 

BUILO 

30 

GO  TO  50 

BUILO 

11 

6 NCONTU=NCONTU^ 1 

BUILO 

32 

IFfNCONTU  .LE.  191  GO  TO  7 

BUILD 

33 

IERR=1 

BUILO 

3H 

CALL  ERRORU) 

BUILO 

35 

RETURN 

BUILO 

36 

7 CONTINUE 

BUILO 

37 

C»*  store  COLUHNS  7-72  OF  CONTINUATION  CARO 

BUILO 

38 

DO  6 1^1,66 

BUILO 

39 

S AfNCHAR»I)*B(I«^61 

BUILO 

40 

NCMAR:NChAR*66 

BUILO 

41 

GO  TO  50 

BUILO 

42 

10  tCRR^e 

BUILD 

43 

9 CONTINUE 

BUILO 

44 

C**  END  OF  STATEHENT,  STORE  NUMBER  OP  CHARACTERS 

BUILO 

45 

N: NCHAP 

BUILO 

46 

RETURN 

BUILO 

47 

END 

BUILD 

48 

I 


I 
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SUBROUTINE  CAA (tSTR,HSTR*IOI 

CAA 

2 

COHHON  Afl3?6l  •Of500>«IOTeL(6«50l)*INITIOI3) .LAST IOC 3) tISRCHfSI, 

RICH 

2 

• JPTR«N,H«jTYP,LSTART«N3,IFNCNH«LOGlD«NXTlOt  10  TY  P,  NtOt  LOG  t 

CY9  8A 

60 

2 LTYP, ITVP*I0LKOT,HOOE  *IERR. lOES 

RICH 

k 

DIMENSION  I$TR(6) 

CAA 

k 

DATA  MASK/7700a009000000000000B/ 

CAA 

5 

IFIMSTR  *GT.  6 .AND.  ITYP  .NE.  261  CALL  ERR0R(6» 

CAA 

6 

I0«0 

CAA 

7 

NSHIFT^GS 

CAA 

6 

00  20  I«ltlO 

CAA 

9 

NSHlFT»NSMIFT-6 

CAA 

10 

IF (I  *GT.  HSTR)  GO  TO  10 

CAA 

11 

J-ISTR(II  .AND*  MASK 

CAA 

12 

IO«IO  .OR*  SHIFT (JfNSHIFTI 

CAA 

13 

GO  TO  20 

CAA 

ih 

to  10*10  *OR.  SHIFT  IlL  .NSHIFTI 

CAA 

19 

20  CONTINUE 

CAA 

16 

RETURN 

CAA 

12 

END 

CAA 

IS 

SUBROUTINE  UI  (ISTR.MSTR,  INTVALI 

CAI 

2 

OINENSION  ISTRIIO) 

CAI 

3 

IFIHSTR  .CT.  101  GO  TO  ?0 

CAI 

6 

INTVAL^O 

CAI 

5 

DO  10  I'l.NSTR 

CAI 

6 

INT»(SHIFT(ISTR«  I»,  61  .»NO.  77B«  - 77 

CAI 

7 

IFdNT  .EQ.  01  GO  TO  10 

CAI 

0 

intv»l*int»*l*int»io»»  chstr-ii 

CAI 

9 

CONTINUE 

CAI 

10 

IFIINTVAL  .GT.  I7»»31-1I»  GO  TO  ZO 

CAI 

11 

RETURN 

CAI 

12 

CALL  ERROR(}l 

CAI 

13 

RETURN 

CAI 

1% 

ENO 

CAI 

19 

IJ 


SUBBOUTINf  C»LL 

CALL 

2 

COMMON  A«1S26)  ,OC;OOI  . lOTBLtS.SOO)  . INITIO  ())  ,L  *STlOI  3)  , ISRCHI  3)  , 

RICH 

2 

• JPTR.N.M,  JTTP,LST*PT,N2,  IPNCNM.L  OG  10  f NX  TIO,  10  TTP.NIO,  LOC  , 

CY58A 

SO 

2 LTTP, ittp,iblkot,nooe,ierr.iofs 

RICH 

k 

comnon/string/nttpe.nstr.str  (500I 

CALL 

k 

COMMON/LIST/NL IST.NINTFC. ISUBLT (2.200  t .INTFACI  30 0> 

CALL 

5 

OIMENSION  lALPH(A) 

CAL  L 

6 

INTEGER  BLANK, BITPUT.BITGET 

call 

7 

DATA  lIALPHdl  ,I>l,G)/lHC.lMA,lNL,iHL/ 

CALI 

a 

DATA  LP0R/1M(/,B|.ANK/1H  / 

call 

9 

C»»  C»LL  STATEMENT  PROCESSOR 

call 

10 

00  S I<1,G 

CALL 

11 

IF  (neat  ( JPTRI  .NE.  lALPHdll  GO  TO  $0 

CALL 

12 

5 CONTINUE 

call 

13 

IPTr.JPTR 

CALL 

Xk 

C»»  GET  SUBROUTINE  NAME 

CAL  L 

15 

call  GNIE 

CALL 

16 

IF(jIYP  .nE.  2)  GO  TO  50 

CALL 

17 

if(nxtio  .eo.  ifncnmi  call  error<io,nxti oi 

CALL 

IS 

C»»  STORE  IN  STMSa  table 

CALL 

19 

CALL  SEARCH 

CALL 

?0 

IFdSRCHdl  .EQ.  11  CALL  E RBOR  (2G.NXTI0I 

CALL 

21 

IF(ISRCH(2I  .EQ.  1)  GO  TO  8 

CALL 

22 

I0TYP«2 

CALL 

23 

CALL  STORE 

CAL  L 

2k 

LOC<NIO 

CALL 

25 

8 CONTINUE 

CALL 

26 

ILOC>L« 

CALL 

27 

N*T«NEXT(JPTR» 

CAL  L 

20 

IF(NXT  .eo.  LPARI  GO  TO  17 

CALL 

29 

IF(NXT  .NE.  BLAN(d  GO  TO  50 

CALL 

30 

C**  SUBROUTINE  HAS  NO  ARGUMENT  LIST 

CALL 

31 

C»»  CHECK  IF  NAME  MAS  APPEARED  PREtdOUStT 

CALL 

32 

IF(BITGET(I0TBL«3.L0C).18,lt  .EO.  It  GO  TO  20 

CALL 

33 

C»»  NAIC  MAS  NOT  YET  APPEARED 

CALL 

3k 

C»»  set  -APPEARED"  FLAG 

CALL 

35 

IDTBL  (3.LOCI:BITPUTdDTSL(3,LOCI.1.18l 

CALL 

36 

C»»  SEARCH  THE  SESCDHP  LIST 

CALL 

37 

DD  10  I»1,NLIST 

CAL  L 

30 

IFdOTBL  (l.LOCI  .NE.  ISUBLTd.III  GO  TO  10 

CALL 

39 

C*»  NAME  FOUND  IN  LIST 

CALL 

60 

C»»  STORE  LIST  LOCATION  IN  SYMBOL  TABLE 

CALL 

61 

lOTBL  (3,LOCI:BITPUT(IOTBL(3,LOCI  .1,361 

CALL 

62 

LISTLC*! 

CALL 

63 

GO  TO  22 

CALL 

66 

10  CONTINUE 

CALL 

65 

C*»  NAtC  IS  NOT  IN  SESCOHP  LIST 

CALL 

66 

C**  PUT  NAME  IN  LIST  ANO  ISSUE  MARNING  MESSAGE 

CALL 

67 

W.IST.NLISTM 

CALL 

60 

ISUBLT  (l.NLISTXIOTBLd.LOCI 

CALL 

69 

I0TBL(3.L0CI<BITPUT(I0TBL(3,L0CI,NLIST,36I 

CALL 

50 

CALL  ERROR (521 

CALL 

51 

RETURN 

CALL 

52 

C*»  NAME  HAS  PREVIOUSLY  APPEARED  - GET  LIST  LOCATION 

CALL 

53 

20  LISTLC*BITGET( I0TBL(3,L0CI .36,51 

CAL  1 

56 

22  CONTINUE 

CALL 

55 

C»*  CHECK  THAT  NUMBER  OF  ARGUMENTS  IS  ZERO 

CALL 

56 

1 < 


IF  (BITGCTdSUBLT  I ZtllSnC)  t6«6)  «Ne,  0)  CALL  emOIM?6) 

C«Ll 

ST 

PETURM 

CALI 

S8 

SU6R0UTI»€  HAS  AN  ARGUNtNT  LIST 

CALL 

S9 

ir  JPTRsIPTR 

CALL 

60 

NT  YPE*1 

CALL 

61 

PARSE  THE  STATENENT 

CALL 

6? 

CALL  EVPR 

CALL 

6J 

CALL  PARSE 

CALL 

66 

C*»  PROCESS  all  external  REFERENCES 

CALL 

65 

CALL  FNCSTR 

CALL 

66 

C**  STORE  BASIC  BLOCKS 

CALL 

67 

call  blkstr 

CALL 

68 

IF IMOOE  .EQ*  1 ) GO  TO  ^8 

CALL 

69 

C»*  ROLL  CALL  HOOE  - NAY  HAVE  TO  ISSUE  A CALL  TO  “ROtCHK“ 

CALL 

70 

LOC*ILOC 

call 

71 

C**  GET  SUBROUTINE  CLASS 

CALL 

72 

IN0EX*BITGET<  I0T6  ' T*LOC  1 « 36 • 9 1 

CALL 

73 

KLAS>BlTGET(ISUB.^  .^f  INDEX  1,10  .III 

CALL 

76 

C**  IF  SESCOHP  NODULE  - ISSUE  A CALL  TO  •ROlCHK" 

CALL 

75 

IFCKLAS  •EQ«  1 .OR,  KLAS  .EQ,  ?l  CALL  CALL? 

CALL 

76 

RETURN 

CALL 

77 

C*«  VARIABLE  PRECISION  HOOE 

call 

78 

C**  ISSUE  calls  to  VARIABLE  PRECISIOh  SUBROUTI  ^S 

CALL 

79 

68  JPTR=IPTR-1 

CALL 

so 

CALL  CNVRT 

CAL  L 

81 

RETURN 

CALL 

8? 

SO  CALL  ERRORtri 

CALL 

83 

RETURN 

CALL 

86 

END 

CALL 

85 

subroutine  call? 

CALLZ 

? 

COHNON  A(13?6)  , 0 ( 5 00  ) • 10  TBL  ( 8 , <;  0 0 1 , I N I TI  01  3 ) ,L  AS  T ID  ( 3 > •ISRCH(3), 

RICH 

? 

• JPTR,N,H, JTYP ,LSTART,N?, I FNC NM , L OGIO , NX TI 0, 10  TYP.NIO, LOC, 

crs  8A 

80 

? LTYP,  ITYP, IBLKOT  ,MOOE ,IERR, lOFS 

RICH 

6 

INTEGER  A,OfCOHHA,RPAP 

CALLe 

6 

INTEGER  0ITPUT,BITGET 

CALL^ 

5 

OmNSlON  IALPH(13t 

CAL  L? 

6 

DATA  RPAR/IH) /,C0HHA/1H,/ 

CAILZ 

7 

DATA  UALPHII ) , I»l,l  J)/1HC,1HA,  1 HL,1HL«1  H , 1 HR  , 1 HO  • 1 HL  # 1 HC«  1 HH  , 

CALL2 

8 

1 1HK,1M  ,1HC/ 

CALL3 

9 

this  ROUTINE  GENERATES  A CALL  TO  “ROLCHK**  OF  THE  FORH 

CALL? 

10 

C** 

call  ROLCHK  aHN,lHA,lHM,lHE,lH  ,1H  f 

CALL? 

11 

00  15  J«l,13 

CALL? 

1? 

K=  J^6 

CALL? 

13 

A<KI*IALPH(  Jl 

CAL  L? 

16 

15  continue 

call? 

15 

GENERATE  ARCUHENT  LIST 

CALL? 

16 

00  ?C  1*1,6 

CALL? 

17 

KK*19»6*  I 

CALL? 

18 

AIKK>3)*1H1 

call? 

19 

A(KK*?)slHH 

CALL? 

?0 

IP0S*6*I 

CALL? 

?1 

IVL*BITGET(IOT0L (1,L0C>, IPOS, 61 

CALL? 

?? 

AIKK-l>a0lTWT<O*IVL*6l 

cal  L? 

?3 

IF  M ,E0,  6)  GO  TO  ?5 

cal  1? 

?6 

?o  ackkmcomha 

CALL? 

?5 

75  A(KKt»RPAR 

call? 

?6 

N=KK 

CALL? 

27 

RE  TURN 

cal  L? 

?8 

FNO 

CAL  L? 

?9 

r 


SUBROUTTNE  C« R (RN« NCHARt I OES 1 

CAR 

2 

OINEMSION  IH0LC4> 

CAR 

3 

INTEGER  RNUOl  tRL  ANK«CHAR 

CAR 

4 

DOUBLE  RRECISION  OPVAL 

CAR 

5 

DATA  RHAX,RHIN,BLANK/1,0E«38 OE-38,550  00  0 0 00  OOOOOOfOOOQB/ 

CAR 

6 

TFCNCHAR  «GT.  ?0«IIOES«1II  RETURN 

CAR 

7 

KOUNTxO 

CAR 

0 

ICHARaNCHAR^l 

CAR 

9 

00  5 1^1 « 4 

CAR 

10 

5 

iHotm«o 

CAR 

11 

NMs2*I0ES^3 

CAR 

12 

10 

NW«NW-1 

CAR 

13 

NSHIFT=0 

CAR 

14 

15 

KOUNT«KOUNT^t 

CAR 

15 

IFtKOUNT  «GT.  NCHARI  GO  TO  20 

CAR 

16 

ICHAR>ICHAR-1 

CAR 

17 

CHARsRNI rCHARI  «ANO.  2 70 0000000 00 OOOOf 00  OS 

CAR 

10 

GO  TO  25 

CAR 

19 

20 

CHARsBLANK 

CAR 

20 

?5 

NSHIFT«NSHIFT 

CAR 

21 

iHOLiNMIalHOL (NWI  .OR.  SHIFT (CHAR* NSH I FT ) 

CAR 

22 

IFINSHIFT  .LT.  601  GO  TO  15 

CAR 

23 

IFfNH  .GT*  1)  GO  TO  10 

CAR 

24 

IFdOES  .EQ.  11  GO  TO  35 

CAR 

25 

DECODE (2Q«30,  IHOL ( 1) 1 RVAL 

CAR 

26 

30 

FORMAT  (E20.0) 

CAR 

27 

IFIRVAL  .EQ.  0.01  RETURN 

CAR 

20 

IFCRVAL  .GT*  RNAX  .OR.  RVAL  .Lt*  RHINI  CALL  ERR0RI46) 

CAR 

29 

RETURN 

CAR 

30 

3S 

OECOOE(40«40,  IHOL  (IM  OPVAL 

CAR 

31 

40 

FORMAT  (040«0) 

CAR 

32 

IF<OPVAL  .EO.  0.0)  return 

CAR 

33 

IFfOPVAL  .GT.  RHAX  .OR.  OPVAL  .LT.  RMIN)  CALL  ERR0R(46) 

CAR 

34 

RETURN 

CAR 

35 

END 

CAR 

36 

SUBROUTlNt  CMKLST 

Chrl 1ST 

2 

COMMON  4 U3  36), 01  50  0)*lOTBLMrS00),INlTl  0131. L AST  1 0 ( 3 ) , I SRCH  1 3 ) , 

RICH 

2 

• JPTP,N,M, JTYP ,LST»»T ,N3, I FNC NH , u OGI 0 , NX TI 0 , 10  TVP.NIO, LOC, 

CY58A 

80 

2 LTYP, ITYP,IRLX0T .MOOC , If RP. IOFS 

RICH 

4 

OIMFNSION  rOUI VI  100) 

chxlist 

4 

fOUIVALf  NCE  IIOUI  V<  1)  • A (301)1 

CHKLIST 

5 

INTEGER  BITGtT 

CHKL 1ST 

6 

This  routine  is  cailed  prior  to  the  flow  analysis  to  flag 

CmklIST 

7 

c**  all  initially  oefineo  variables 

ChklIST 

6 

NQUIVsO 

CmxlIST 

9 

00  3C  1*1, NIO 

CMKLIST 

10 

IOTBL ( a, I)»0 

CMXLIST 

11 

IF  (BITGE  TUOTBl  ( 3,11 ,14, 1 ) .fO.  U GO  TO  30 

CMKLIST 

12 

IF  IfllTCET IIOTBL 1 3, 1) , 16, 1 ) ,EQ.  1)  GO  TO  5 

CHKLIST 

13 

IF (BITGE T 1 lOT BL( 3,1) ,1?, 1 ) ,E0.  1»  GO  TO  15 

CHKLIST 

14 

GO  TO  10 

CMKLIST 

15 

C**  variable  I)»  common  - SET  INITIALLY  OEFINfO  FLAG 

CHKLIST 

16 

5 IOTBL  (S,I)*1 

CHKLIST 

17 

10  IFC8ITGET(10TBL(3,I),IT,1)  ,NE.  1)  GO  TO  30 

CMKLIST 

10 

C**  variable  IS  EOUIVAlENCEO  - STORE  IN  LIST 

CHKLIST 

19 

NQUIV=NQUIV#1 

CMKLIST 

20 

IFINOUIV  ,GT.  100)  GO  TO  60 

CY58A 

52 

IQUIV (NQUIV)* I 

CMKLIST 

21 

GO  TO  30 

CMKLIST 

22 

C**  VARIABLE  IS  FORMAL  PARAMETER  - FLAG  IF  INPUT 

CMKL 1ST 

23 

15  IF  IBITCfT (IOTBL 13,1) ,37, 1 ) ,EQ.  0)  GO  TO  30 

CMKLIST 

24 

c**  variable  IS  oefinco  by  data  statement  or  is  input 

CHKLIST 

25 

IDT6L(8,n*l 

CHKLIST 

26 

30  continue 

CHKLIST 

27 

IF(NOUIV  ,EO.  0)  RETURN 

CMKLIST 

28 

00  50  J=l,NQUIV 

CHKLIST 

29 

NXOVsIQUIV (J) 

CMKLIST 

30 

GET  NEXT  EOUIVALENCEO  VARIABLE 

CMKLIST 

31 

35  NXOVsIOTSL (7,NXQV) 

CHKLIST 

32 

IFINXQV  «EO,  lOUIV(J))  GO  TO  50 

CMKLIST 

33 

IF (IOTBL (8,NXQV)  .EQ,  0)  GO  TO  35 

CMKLIST 

34 

c**  variable  in  equivalence  link  is  OEftNea 

CMKLIST 

35 

lOVsNXOV 

CHKLIST 

36 

C**  CHECK  TYPE  OF  DEFINED  VARIABLE 

CHKLIST 

37 

KTYPE«BITGET( I0TBL(3,IQVI , 10, 31 

CMKLIST 

38 

40  NX0V=I0TBL(7,NX0V) 

CMKLIST 

39 

IF(NXQV  .EQ,  IQV)  GO  TO  50 

CMKLIST 

40 

IF(BITGET(IOT9L(3,NXQV),10,3I  NE.  KTYPC)  GO  TO  40 

CHKL 1ST 

41 

C**  variable  in  equivalence  LINK  HAS  SAME  TYPE  - SET  FLAG  TO  ~0EFINE0- 

CMKLIST 

42 

I0TBL(8,NXQV)  «1 

CHKLIST 

43 

GO  TO  40 

CMKLIST 

44 

50  CONTINUE 

CHKLIST 

45 

RETURN 

CMKLIST 

46 

60  CALL  ERR0R(94) 

CY5BA 

53 

RETURN 

CY58A 

54 

END 

CMKLIST 

47 

subroutine  a»ss  class  2 

COMMON  A 11326)  »0  fSOO  U IOTBL  f 8,S00  U INITIon)  ,L  ASTIOl  3)  • ISRCH13  U RICH  2 

• JPTR,N,N* JTYP.LSTART, N2 • IFNC NH , L OG I D , MX T 1 0 * TO TY P , NIO * LOC . CY5  6A  BO 


2 L typ, ityp, IBLKOT ,hooe  *ierr* iofs 

RICH 

4 

DIMENSION  KALP148I, 

KSUCl 48)«KF AL (46I.KOEC110I* 

KF  181 

CLASS 

4 

INTEGER  A 

CLASS 

5 

C** 

THIS  routine  classifies  fortran  statements  into 

36  CLASSES 

CLASS 

6 

c** 

ANO  STORES  THE  CLASS 

IN  -I  TYP- 

CLASS 

7 

c** 

1-ASSIGNMENT 

2-ASSICN  3-GO  TO 

4-ASSO.  GO 

TO 

CLASS 

8 

c** 

5-COMP,  GO  TO 

6-ARlTM.  IF  7-CONTINUE 

8-CALL 

CLASS 

9 

c** 

9-RETURN 

lO-STOP  It-REAO 

12-NRITE 

CLASS 

10 

c** 

13-RENlNO 

14-BACKSPACE  15-ENOFILf 

16-L  OGICAL 

IF 

CLASS 

11 

c** 

17-00 

le-ENO  19-INTEGER 

20-REAL 

CLASS 

12 

c** 

21-OOUB.  PREC. 

22-complex  23-LOGICAL 

24-OlMENSION 

CLASS 

13 

c** 

25-COMHON 

26-EQUIVAlFNCE  27-OATA 

2B-F  ORMAT 

CLASS 

14 

c** 

29-BLOCK  OATA 

30 -SUBROUTINE  31-FUfCT ION 

32-PROGRAM 

CLASS 

16 

c** 

33-36  INVALID 

CLASS 

16 

OATA  KOEC  <1 1*  K0EC12)*K0ECl3)*KnECl4),KDECI6l* 

CLA  SS 

1* 

1 KOEC (61 *KOEC (71 *KOEC (81  * KOEC (91  * KOEC (1  Of 

CLASS 

18 

2 /1hO*1H1,1H2*1H3* 

1H4,1M6*1H6*1M7*IH8*1  H9/ 

CLASS 

19 

OATA  KF(1I,KF(2I,KF(3I*KF<4)*KF16),KF16I,KF(7I 

*KF18) 

CLASS 

20 

I /1MF,1MU*IMN,1HC 

* IHT*  IHI.  IMO*  IWN/ 

CLASS 

21 

DATA  KCvKBLNK, KLPAR 

.KRPAR.KEO  /1MC*1H  * IHl.lHI.lM*/ 

CLASS 

22 

DATA  KH.KSLSH.KASTk 

*K2ER0,KCMA  /I  MM,  1H/,1H*,1H0,1H,/ 

CLASS 

23 

c»» 

character  array  for  tree  SCAN 

CLASS 

24 

DATA  KALPI  1)  *KALP( 

21, KALPI  3»*KALP1  4)  /IHI* 

IMF,  IHN*  IMG/ 

CLASS 

25 

OATA  KALPI  5)«  KALPI 

6I*KALP(  7)*KALP1  8)  /IHO* 

1HT,1H0*1H|/ 

CLASS 

26 

DATA  KAlPI  si « XALPllOl ,KALP< 11> f KALPt 121  /I HCt  IH A , 1 HO* IHN/ 
DATA  KALPI  131  •KALPtl4l«KAlPnS),KALP(16l  /1HH«1HH,1HP,1HR/ 
DATA  KALP(12)*KALP<18I*KALP(1S)*KALP(20I  /lHF*iHA,lHO,lHL/ 
DATA  KALPI21I  *KALPf22l  «KALP(23)  «KALP(24»I  /IMT,  IHK,  IMf  * IMO/ 
DATA  KALP(?SI  *KAL P 1261 ,KALP( 27  I «K ALP  <2  Bl  /I HU*  1H0*1HI, IHA/ 
DATA  KALP129I  *KALP(30I *KALP<3t I,KALP<32I  /IHO*  INU* IHM, IHS/ 
DATA  KALPf 331  * KALP  1341 .KALPI 361 *K ALP 1 361  /IHT,  IHU* IMf • IHN/ 
OATA  KALP137)  •KAlP(3ai  *KALP(  391  «KALPf40>  / 1 HO*  IMF , IHX * 1 HO/ 
DATA  KALP1411*KALP142)*KALP1431,KALP144)  /IHB*  1HA*1HL*1HA/ 
DATA  XALP146)  » KALP146I  »KALP(47I  *KAL^148)  /IHL  ,1  )«>*1HR*  IHO/ 
SUCCEED  LINK  FOR  TREE  SCAN 


CLASS 

CLASS 

CLASS 

CLASS 

CLASS 

CLASS 

CLASS 

CLASS 

CLASS 

CLASS 

CLASS 


27 

28 

29 

30 

31 

32 

33 

34 

35 

36 

37 


OATA 

KSUCl  11 

•KSUCl  2I,KSUCI  31 

•KSUCl  41 

/ 

2,  -6^-19^ 

6/ 

CLASS 

30 

OATA 

KSUCl  51 

*KSUC1  6) *KSUC1  71 

• KSUCl  8) 

/ 

6*  7^  8^ 

-5/ 

CLASS 

39 

OATA 

KSUCl  9) 

, KSUCIIOI *KSUC1  111 

• KSUC  (121 

/ 

10^  -8^  12^ 

-7/ 

CLASS 

40 

data 

KSUC  1131 

•KSUCI14I *KSUCI15I 

•KSUC (161 

/ 

14^ -25, -22^ 

17/ 

CLASS 

41 

OATA 

KSUCI17) 

*KSUCI18I *KSUCI 191 

• KSUC  I 2 0) 

/ 

18,  19,-11, 

-20/ 

CLASS 

42 

OATA 

KSUC121I 

•KSUCI22I*KSUC(23» 

• KSUCI24I 

/ 

-9,-13,  24, 

-28/ 

CLASS 

43 

DATA 

KSUCI25I 

«KSUCI26I,KSUC(27I 

•KSUC126) 

/- 

31,  27,-?4, 

-27/ 

CLASS 

44 

DATA 

KSUC  1291 

• KSUCI30I *KSUCI31 1 

•KSUC(32> 

/ 

30,  -21,-12, 

33/ 

CLASS 

45 

OATA 

KSUCI33I 

• KSUCI34I *KSUCI 361 

•KSUC (3 6) 

/- 

10,-30,  36, 

37/ 

CLASS 

46 

OA  TA 

KSUC  1371 

«KSUC(3§I«KSUCI39> 

•KSUC (401 

/ 

38, -15,-34, 

-26/ 

CLASS 

47 

OATA 

KSUCI41I 

•KSUCI42I ,KSUC(4S) 

•KSUC 1 44) 

/ 

42,  -14,-29, 

-2/ 

CLASS 

48 

OATA 

KSUCI45) 

,KSUCI46I,KSUC(47I 

•KSUC 1481 

/- 

23,  47, 48,-32/ 

CLASS 

49 

FAIL  LINK  FOR  TREE  SCAN 

CLASS 

50 

OATA 

KFALI  11 

•KFALI  21 ,KFAL1  31 

•KFALI  41 

/ 

4,  3,-36, 

9/ 

CLASS 

51 

OATA 

KFALI  51 

• KFAL 1 61 •KFALI  71 

• KFALI  81 

/- 

36,  -36,-36, 

-3/ 

CLASS 

52 

DATA 

KFALI  91 

•KFALIIOI •KFALlllI 

•KFAL 1121 

/ 

16,  ll,-36. 

13/ 

CLASS 

53 

OATA 

KFAL  1131 

•KFALI14I *KFAL(15I 

•KFAL (161 

/- 

36,  15,-36, 

23/ 

CLA  SS 

54 

OATA 

KFALliri 

•KFALIl 81 *KFALI19I 

•KFAL 1201 

/- 

36,  21*  20, 

-36/ 

CLASS 

55 

OATA 

KFALI21I 

•KFAL<22I*KFALI2SI 

• KFAL  <241 

/ 

22, -36,  26, 

25/ 

CLASS 

56 

1 . 


DATA  KFAL (?5) • KFAl (26) «KF AL ( 27) t KFAl ( 28) 
DATA  KFAl (29) • KF At ( 3 0) «KF AL( 31) , KFAl (32) 
DATA  KFAL (33) » KFAL  (3V) »KF AL ( 39 ) • KFAL ( 36) 
DATA  KFAL(37)«KFAL(38)tKFAL(39)tKFAL(l*0) 
DATA  KFAL  (^1)  • KF  Al  (A2)  .KFAL  ( <*3  ) « KFAL  ( A%) 
DATA  KFAL (H9)  • KFAL  (66)  • KF AL ( 47 ) • KF AL ( 48)  < 
LTTPsO 
IPTR*7 
9 CONTINUE 
JSAVE»K0LNK 
JSM*0 
ISN*C 
JE  O»0 
JCHA  = 0 
JMOLL»0 

C**  ASSIGNMENT  SCAN  LOOP 
00  26  J»IPTR,N 
XH«A(  J) 

IFUCH  .EQ.  KBLNK)  GO  TO  26 
C**  IF  not  blank,  check  for  HOLLERITH  SNITCH 
IF  (JHOLL  .LC.  0)  GO  TO  12 
00  8 L^ltlO 

IF(JCH  .EO.  <OEC(D)  GO  TO  10 
S CONTINUE 

FIRST  TI»C.  NO  integer  MEANS  NOT  HOLLERITH 
IF (JMOLL  .LE.  1)  GO  TO  11 
OTHERMISE  LOOK  FOR  -M~ 

IF(JCH-KH)  11,32.11 
still  fits  HOLLERITH  SYNTAX 

10  JHOLL*  JMOLL^l 
GO  TO  25 

NOT  A HOLLERITH  CONSTANT,  SET  SNITCH  OFF 

11  JHOLL*0 

TEST  OTHER  CHARACTERS  ().*/• 


1?  IF(JCH 

• EQ. 

KLPAR) 

GO  TO 

20 

IF (JCH 

• EO. 

KRPAR  ) 

GO  TO 

18 

IF (JCH 

• EO. 

<CMA ) GO  TO  22 

IF (JCH 

• EO. 

KEQ)  GO 

TO  23 

IF (JCH 

• EO. 

KSLSM) 

GO  TO 

21 

IF  (JCH- 

KASTK)  25,21 

,25 

C** 

C»* 

C** 

C*‘ 

C* 


C**  RIGHT  PA9EN  FOUND 
18  JSN*JSN-1 

IF  (JSN  ,GT,  0)  GO  TO  25 
C**  SET  SNITCH  TO  ALLOW  ONLY  ONE  MORE 
ISN*1 
GO  TO  26 

C**  LEFT  PAREN  roUNO 

20  JSNsjSN^l 

C»*  SET  HOLLERITH  SNITCH  FOR  (,/• 

21  JHOLL»l 
GO  TO  25 

C**  COMMA  FOUND,  CHECK  LEVEL 

22  IF  (JSN)  30.30.21 

C**  EQUAL  SIGN  FOUND,  CHECK  LEVEL 

23  [F(JSN  ,GT.  0)  GO  TO  32 
JEO»l 

C**  TEST  IF  TERMINATED  BY  SNITCH  SET 


/-36,  31,  28,  29/ 

CLA  SS 

57 

/-36,-36,  32,  35/ 

CLASS 

58 

/ 34,-36,  41,  39/ 

CLASS 

59 

/-36,-18,  40,-36/ 

CLASS 

60 

/ 44,  43,-36,  45/ 

CLASS 

61 

' 46,-  36,-36,-  26/ 

CLASS 

62 

CLASS 

63 

CLASS 

64 

CLASS 

65 

CLASS 

66 

CLASS 

67 

CLASS 

68 

CLASS 

69 

CLASS 

70 

CLASS 

71 

CLASS 

72 

CLASS 

73 

CLASS 

74 

CLASS 

75 

class 

76 

CLASS 

77 

CLASS 

78 

CLASS 

79 

CLASS 

80 

CLASS 

81 

CLASS 

82 

CLASS 

83 

CLASS 

64 

CLASS 

85 

CLASS 

66 

CLASS 

87 

CLASS 

88 

CLASS 

09 

CLASS 

99 

CLASS 

91 

CLASS 

92 

class 

93 

CLASS 

94 

CIA  «S 

95 

CLASS 

96 

CLASS 

97 

CLASS 

98 

CLASS 

99 

c character 

CLASS 

100 

CLASS 

101 

Class 

102 

CLASS 

103 

Class 

104 

Class 

105 

CLASS 

106 

CLASS 

107 

Class 

106 

CLASS 

109 

CLASS 

110 

CLASS 

111 

CLASS 

112 

CLASS 

113 

IS 


^5  IF  lISM  , GT.  0 » GO  TO  ?7 

Cl»SS 

114 

?6  CONTINUE 

CLASS 

115 

GO  TO  28 

CLASS 

116 

C**  SAVE  CAST  CNARACTEft  IF  TERHlNATED  EARLY 

CLA'S 

117 

27  JSAVFsJCH 

CLASS 

1 18 

C**  ONE  NON-BLANK  CHARACTER  AFTER  A RIGHT  PAREN 

CLASS 

119 

C**  NIGHT  BE  AN  ASSIGNMENT 

CLASS 

120 

JP=J 

CLASS 

121 

28  IF (JEQ  .LE.  0)  GO  TO  32 

CLASS 

122 

JTP=1 

CLASS 

123 

GO  TO  55 

CLASS 

124 

C**  UPPER  LEVEL  COMMA  FOUND 

CLASS 

125 

C**  NIGHT  BE  A DO 

CLASS 

126 

3 0 JCMA  = 1 

CLASS 

127 

IF(JEQ  .LE.  0>  GO  TO  3? 

CLASS 

128 

JTP=17 

CLASS 

129 

GO  TO  55 

CLASS 

130 

HOLLERITH  CONSTANT  FOUND 

CLASS 

131 

3?  J=1 

CLASS 

132 

ISW=IPTR 

CLASS 

133 

33  jCHsACISMJ 

CLASS 

134 

IFIJCH  .EQ.  KBLNKI  GO  TO  57 

CLASS 

135 

C**  TEST  AGAINST  CURRENT  TREE  CHARACTER 

CLASS 

136 

3<»  IF(JCM  .EQ,  KALPCJM  CO  TO  36 

Class 

137 

C**  IF  NO  MATCH,  TRY  NEXT  IN  TREE 

CLASS 

136 

35  J=KFAL«J) 

CL  A SS 

139 

IF  (Jl  35,39,34 

CLASS 

140 

C**  character  HATCHES,  TRY  NEXT  IN  TREE 

Class 

141 

36  J*KSUC<J) 

class 

142 

If  (J  .IE.  Of  GO  TO  39 

CLASS 

143 

37  ISH*ISM»1 

CLASS 

144 

IF  (ISM  .lE.  N>  GO  TO  33 

Class 

145 

c**  PUN  OUT  OF  characters 

CLASS 

146 

JCHsKBLNK 

CLASS 

147 

GO  TO  35 

CLASS 

148 

C**  CL ASSIFICAT ION  COMPLETED,  FORM  TYPE  COOF 

class 

149 

39  JTPs-J 

Class 

15C 

C**  CHECK  TO  SEE  If  MOPE  TREATMENT  NEEOEO 

class 

151 

IF<jTP-3»  55,45,40 

CLASS 

152 

40  IF(jTP-6»  55,43,41 

class 

153 

41  IF  (JTP  ,LT.  191  GO  fO  55 

CLASS 

154 

IF(jTP-?3)  47,  47,55 

CLASS 

155 

C»*  LOGICAL  IF  SEPARATION  TEST 

CLASS 

156 

43  00  44  L=1,10 

Class 

157 

IF<JSAVE  .EQ.  KOFCID)  GO  TO  55 

CLASS 

158 

44  CONTINUE 

CLASS 

159 

LTYPS9 

CLASS 

160 

JTP'16 

class 

161 

TPTRs  JP 

CLASS 

162 

GO  TO  5 

CLA  SS 

163 

C**  SEPARATE  assigned  AND  UNCONDITIONAL  GOTOS 

CLASS 

164 

45  IF  (JCMA  .LE.  0 ) GO  TO  55 

class 

165 

jTPi4 

CLASS 

166 

GO  TO  55 

CLASS 

167 

C**  CHECK  whether  this  is  A TYPE  STATEHENT  OR  TYPED  FUNCTION 

CLASS 

168 

47  L=ll 

class 

169 

o 

o 

CLASS 

170 

48  L*L*1 

CLASS 

171 

IF  CL  .GT.  N)  GO  TO  55 

CLASS 

172 

IFCAIL)  .EO.  KBLNK)  GO  TO  48 

CLASS 

173 

53  IFIA(L>  .EO.  KFCISWM  GC  TO  53 

CL  ASS 

1 74 

IF (ISW  .EO.  1 ) GO  TO  48 

CLASS 

175 

52  ISW=1 

CLASS 

176 

GO  TO  50 

CLASS 

177 

53  ISHsiSMfl 

Cl  ASS 

178 

IF  IISW  .LF.  6)  GO  TO  4ft 

CLASS 

179 

jTPs  31 

CLASS 

180 

55  TTYP*JTP 

CLASS 

161 

C**  all  results  come  mERF  FOP  rfturn 

Cl  A SS 

182 

PFTURN 

CLASS 

183 

END 

Cl  A >:s 

184 

[ ‘'uri^CUTTNE  C'<°aPf 

[ niMr  r.slON  tROLCK  UOC  ) • ISUR  (10  3 » 

I Of  WIND  1 

[ NSUR=: 

\ NC  = 0 

f'C  1 = 1,130 
pefiO(9)  ISUR(I» 

IF  (fcOF  (9)  ,nE . C ) GO  TO  7 
N$UR=NSUR*1 
5 ^C^TINU' 

7 IF(NSUR  .EQ.  0)  PETURN 
no  4.  L=l,l? 

MOOt=L-l 

NPCLL=: 

no  1C  1=1, lo: 

PEflO(3)  IPOl:k(I) 

IF  (f  OF  (3»  ,N£  , 0 1 GO  TO  15 
NPOLL  = NPOLL*'l 
13  CONTINUE 

15  IF<NPOLL  ,EO.  C)  GO  TO  35 
no  3:  j= 1 ,nsur 
00  2i  K=l,NPOLL 

IF(IPOLC<(K)  ,EO.  ISURCjn  GO  TO  30 
?3  CONTINUE 
NC=1 

WPTTc (6,25)  r SUB (J), HOPE 

25  FOOMfiT (/29X,12H  SURPOUTINF  ,A6,53h  WAS  NOT  CALLED  IN  T Mf  POLL  CALL 
• MOOf  FOP  node  index  ,13) 

70  CONTINUE 
GO  TC  4C 

35  WPITE (fc, 36)  HOOE 

I 36  FORMAT «/ 3?*, 65H  NO  SUBROUTINES  WE^E  CALLED  IN  THF  POLL  CALL  HOOE  F 

I *OR  MOO?  INDEX  ,13) 

NC  = 1 

43  CONTINUE 

IFCNC  .ED,  0)  WPITE(6,50) 

53  FORMAT (/41*,5C H ALL  SUPPOUTINES  WERE  CALLED  IN  TMC  POLL  CALL  MODE) 

! RETURN 

fNC 


.’I) 


suepouTiNe  cmvrt 

CNVRT 

2 

COHHON  AU336»  •0<5QO)«XOTflll$t500»»IHITIO(3}  tl  AS T in t 3 ) • I SPCH  ( 3 > . 

RIC  H 

2 

• JPTR,N,N,jTrP,LSTART,N2, IFNCNH,LOGIO,N*TIO, IOTYP.NIO.LOC, 

CY58A 

80 

2 LTYP, ITYP,I0L  KOT.HOOE  *IERP* I OPS 

RICH 

4 

COMMON/S TPING/ NT V PE, NS TR,STR 1500) 

CNVRT 

4 

01  HENS  ION  lOP  1 8)  , IL0G)7,2»  ,JLOG<2,3)  , injNCne)  ,irUNC2  1 6)  , 

CNVRT 

5 

1 IfUNC3(6) 

CNVRT 

6 

INTEGER  STP,A ,0,OECPT 

CNVRT 

7 

INTEGER  0ITPUT ,01 TGET 

CNVRT 

8 

DATA  f lOPCII, I=l,a)/1M4,1H-,1M/,1M(,IH»,1H,,1M*,1H*/ 

CNVRT 

9 

DATA  \ ULOGfl  • J)  , J=1 ,?  > , I * 1 ,7  ) / 1 HL  , IHT  , 1 HL  , 1 , 1 MG  , 1 MT  , 1 MG,  1 Hf  , 

CNVRT 

10 

1 1ME,1HQ,1MN,IHE,IHC,1HR/ 

CNVRT 

11 

OAT  A < I JLOGU  ♦ J)  , J*l,3),  1*1,2)  /1HA,IMN,1  MO,lHN  ,IM0,1MT/ 

CNVRT 

12 

OATA  1 IFUNCK  I ),  1*1 ,6)  /I  HQ, IHl  , iM9,l HE  ,1  HA,  IMt  / 

CNVRT 

13 

OAT  A CIFUNC2I  I),I«1,6)/1H0,1HI,1H0,1MP,IHR,1)^/ 

CNVRT 

14 

OATA  { IEUNC3I I),Is1,6)/1M0,im1,1HC,1H0,IHM,1MP/ 

CNVRT 

15 

OATA  OECPT/IM./ 

CNVRT 

16 

c** 

THIS  routine  is  calleo  in  the  variable  precision  hooe  to  OECOOE 

CNVRT 

17 

c** 

the  string  which  is  returned  0Y  the  parser  after  VftRIA0LE 

CNVRT 

18 

precision  calls  have  0EEN  INSERTFO 

CNVRT 

19 

00  5 J»l,JPTR 

CNVRT 

20 

5 0(J)*AfJI 

CNVRT 

21 

C** 

THIS  LOOP  LOOKS  AT  EVERY  STRING  ELEMENT  INDIVIDUALLY 

CNVRT 

22 

J*  JPTR 

CNVRT 

23 

DO  100  k*i,nstr 

CNVRT 

24 

IF<STR(KI  ,GT.  0)  GO  TO  40 

CNVRT 

25 

c** 

special  CHARACTER  OR  OPERATOR 

CNVRT 

26 

00  10  1*1,8 

CNVRT 

27 

IFtSTRCO  .NE,  -II  GO  TO  10 

CNVRT 

28 

C'* 

LOGICAL  OPERATOR  FOUND  - STORE  IN  "0" 

CNVRT 

29 

c** 

CHARACTER  FOUND  - STORE  IN  -Q* 

CNVRT 

30 

O(J^l) =IOPI I) 

CNVRT 

31 

N3«l 

CNVRT 

32 

IF(I  ,NE,  8)  GO  TO  100 

CNVRT 

33 

OIJ42»*IOPCI) 

CNVRT 

34 

N3*2 

CNVRT 

35 

GO  TO  100 

CNVRT 

36 

10  CONTINUE 

CNVRT 

37 

DO  15  1*1*7 

CNVRT 

38 

L*I^8 

CNVRT 

39 

IFISTRIK)  .NE.  -L)  GO  TO  15 

CNVRT 

40 

c** 

LOGICAL  OPERATOR  FOUND  - STORE  IN  -0~ 

CNVRT 

41 

01 J^l 1 *OECPT 

CNVRT 

42 

0(JA2)*lL0Gn,l» 

CNVRT 

43 

0IJ^3)  *ILOG(I  * 2) 

CNVRT 

44 

0IJ^4)*0ECPT 

CNVRT 

45 

N3*4 

CNVRT 

46 

GO  TO  100 

CNVRT 

47 

15  CONTINUE 

CNVRT 

48 

00  20  1*1*2 

CNVRT 

49 

L*I^15 

CNVRT 

50 

IFISTRIIO  .NE.  -L)  GO  tq  20 

CNVRT 

51 

OUtl)  *0ECPT 

CNVRT 

52 

0(J»2>*JL064t*  1) 

CNVRT 

53 

01 J»3) *JLOGII * 2) 

CNVRT 

54 

0U^4l*JL0GfI*3l 

CNVRT 

55 

OCJ^5)*OECPT 

CNVRT 

56 

N3*5 

CNVRT 

57 

GO  TO  too 

CNVRT 

50 

20  CONTIMUC 

CNVRT 

59 

C**  HUST  BE  A CALL  TO  A VARIABLE  PRECISION  SUBROUTINE 

CNVRT 

60 

KL»1 

CNVRT 

61 

IMSTRIKI  •EQ.  -0)  KL«2 

CNVRT 

63 

IMSTROO  .EQ.  -lOQOOl  KL*4 

CNVRT 

63 

IFISTROO  .EO«  -30000)  KL*3 

CNVRT 

64 

GO  TO(110f3S,3Q«39),KL 

CNVRT 

69 

C**  CALL  TO  "OIREAL**  - STORE  IN  D- 

CNVRT 

66 

35  00  zr  I«l,6 

CNVRT 

67 

0(  J^DsirUNCl  (It 

CNVRT 

60 

37  CONTINUE 

CNVRT 

69 

N3*6 

CNVRT 

70 

GO  TO  100 

CNVRT 

71 

C**  CALL  TO  "010PRE“  - STORE  IN  "O" 

CNVRT 

73 

30  00  33  Isl«6 

CNVRT 

73 

0(J^I)»IFUNC3(I) 

CNVRT 

74 

33  CONTINUE 

CNVRT 

75 

N3«6 

CNVRT 

76 

GO  TO  100 

CNVRT 

rr 

CALL  TO  -QICOMP-  - STORE  IN  "O* 

CNVRT 

70 

35  00  37  I=l»6 

CNVRT 

79 

0(J^I)sIFUNC3(I) 

CNVRT 

00 

3 7 CONTINUE 

CNVRT 

01 

N3«6 

CNVRT 

03 

GO  TO  100 

CNVRT 

03 

40  IFISTRCK)  .LT*  1000001)  GO  TO  110 

CNVRT 

04 

N3»STR(iO/l.E6 

CNVRT 

05 

H.OCS  (STR(K)/1000  T)  *10  000 

CNVRT 

06 

JPTRsSTROCI-WL  OC 

CNVRT 

07 

KLOCsSTR(K)-N3*1.E6 

CNVRT 

00 

IFOCLOC  .LT.  400000  .OR*  KLOC  •GT.  500000)  GO  TO  50 

CNVRT 

09 

IHL«(KLOC-400000) /lOOOO 

CT61 

1 

IF(ZHL  *E0.  5)  GO  TO  GO 

CV61 

3 

c**  constant  found  - store  in  -0“ 

CNVRT 

90 

00  45  I«1»N3 

CNVRT 

91 

0( J^I)«NE*T(JPTR) 

CNVRT 

93 

45  continue 

CNVRT 

93 

GO  TO  100 

CNVRT 

94 

C**  variable  found  - STORE  IN  “0~ 

CNVRT 

95 

50  00  55  I*ltN3 

CNVRT 

96 

IP0S*6*I 

CNVRT 

97 

ICMAR»0ITGET(  lOTBLd*  JPTR)  .IPOS^G) 

CNVRT 

90 

55  0(J»I)>BITPUT(0,ICHAR,6) 

CNVRT 

99 

GO  TO  100 

CT61 

3 

60  KPTR«JPTR-1 

CT61 

4 

00  65  l3l,N3 

CY61 

5 

65  0(J#I)sA(KPTR»I) 

CT61 

6 

100  JsJ*N3 

CNVRT 

100 

NsJ 

CNVRT 

101 

DO  105  Ist«N 

CNVRT 

103 

105  A(I)«0(t) 

CNVRT 

103 

RETURN 

CNVRT 

104 

110  CALL  ERRORI33) 

CNVRT 

105 

RE  TURN 

CNVRT 

106 

ENO 

CNVRT 

107 

SU8R0UTINC  COH 

com 

2 

COMHON  «ll326).0(SOO).IDTeL(8,SOOI,INITIOI3) 

,L  »STIO(3l ,ISRCH(3I, 

rich 

2 

» JPTR,N,>«,  JTYP.L  START,  N?,  IFNC  NH,  L OGI 0.  NX  TI 0 . 

lorrp.Nio.Loc, 

CY5  0A 

60 

2 LTYP, ITYP,I8LKOT,MOOC  .lERRtlOFS 

RICH 

A 

OIMfNSION  rOIH|3»,IilLPH(6f 

COM 

A 

INTEGtR  SLASH,COHHA,eLANK«A«PPAP 

COH 

5 

INTEGER  eiTPUT ,BITGET 

COH 

6 

DATA  (lALPHCn IHO, 

IHN/ 

COM 

7 

DATA  SLA$H/1-<//,C0MHA/IM,/,SLANK/1H  / • RP  AR/1  H)  /tl  PAR/ 1 H (/ 

COM 

8 

c**  COHHON  STATEMENT  PROCESSOR 

COH 

9 

00  10  1=1,6 

COH 

10 

IF  INEXT  ( JPTRI  ,NE.  lALPHMH  GO  TO  60 

COH 

11 

to  CONTINUE 

COM 

12 

IF (NEXT ( JPTR)  .EQ.  SLASH)  GO  TO  15 

COH 

IS 

JPTRsJPTR-1 

COM 

IV 

c**  blank  common 

COM 

1$ 

13  NXTI0=6LANK 

COM 

16 

GO  TO  20 

COM 

17 

C**  GET  NAME  OF  LA9ELLE0  COMMON  BLOCK 

COH 

18 

15  CALL  GNLE 

COM 

19 

IMA(JPTR-I)  .EQ.  SLASH)  60  TO  13 

COM 

20 

IF (JTYP  .NE.  ?>  GO  TO  60 

COM 

21 

rF(NEXTCjPTR)  .NE.  SLASH)  GO  TO  60 

COH 

22 

C**  STORE  NAME  IN  SYMBOL  TABLE 

COM 

23 

?o  call  COMSCH 

COM 

2V 

IFIISRCHO)  .EO,  1)  GO  TO  35 

COM 

25 

I0TYP»3 

COM 

26 

CALL  STORE 

COM 

27 

icmloc*nio 

COM 

28 

GO  TO  27 

COM 

29 

25  ICML0C=L0C 

COH 

30 

C**  GET  LOCATION  OF  LAST  VARIABLE  IN  BLOCK 

COM 

31 

LSTL0C=r0TBL(6 , rCML OC) 

COM 

32 

C**  GET  NEXT  variable  IN  BLOCK  ANO  STORE  IN  SYMBOL 

T ABLE 

COM 

33 

27  CALL  GNLE 

COH 

3k 

IFIJTYP  .NE.  2)  GO  TO  60 

COM 

35 

CALL  SEARCH 

COM 

36 

IF(ISRCH(2)  .EO.  11  CALC  E RROR  < 10  , NXY  lO) 

COM 

37 

IFdSRCHd)  .EQ.  1)  GO  TO  28 

COM 

38 

lOTYPsl 

COM 

39 

call  STORE 

COM 

VO 

loc=nio 

COM 

VI 

C**  CHECK  VALiniTY  ANO  SET  -COMMON-  FLAG 

COH 

V2 

28  IF  (BITGETI  I0T8L«3,L0CI  .12, 1)  .EQ.  1)  CALL 

ERROR! 17, NXT 10) 

COM 

V3 

IF I6ITGET(I0TBL(3.L0C) .16,1)  .EQ.  1)  CALL 

ERR0R(53,NXTI0I 

COM 

VV 

IOT0L  <3,LOC)=8ITPUTIIOT0L ( 3,L OC ) , 1 , 16 ) 

COM 

V5 

ICHSI2  = 1 

COM 

V6 

IF(NEXT(JPTR)  .NE.  LPARI  GO  TO  AQ 

COM 

V7 

IF(8ITGET(I0TBLI3,L0C)  ,1,1)  .NF.  0)  GO  TO 

80 

COM 

V8 

C**  VARIABLE  IS  OIMENSIONEO 

COM 

V9 

1*0 

COM 

50 

35  I*I»l 

COM 

51 

C»*  GET  NEXT  DIMENSION  ANO  CHECK  SITE 

COM 

52 

call  GNLE 

COM 

53 

IF (JTYP  ,NE.  5)  GO  TO  60 

COM 

5V 

rOIM(I)^N2 

COM 

55 

TCMSI7*ICHSI7*N2 

COM 

56 

i 


IFIH2  .GT.  .OR.  N3  .LE.  01  C*LL  ERPORfOl 

COH 

57 

IE<MEXT(JPTR)  .EO.  COMH»>  GO  TO  35 

COM 

S8 

IF(4(JPTR-1>  .NE.  RPARl  GO  TO  60 

COH 

59 

<=NEXT  (JPTR» 

COH 

60 

C*»  SET  “DIMENSIONED"  FLAG 

COH 

61 

lOTBL  {3.LOCI=8ITPuT(IOT8L  I3.LOC)  ,1,11 

COH 

62 

IF  (I  .GT.  3»  CO  TO  60 

COH 

63 

C»»  STORE  NO.  OF  DIMENSIONS  AND  DIMENSION  SUES  IN  SYMBOL  TABLE 

COH 

6% 

IDTBL  «3.LOC)=BITPUT«IOT8L  «3,L0C)  , I,7» 

COH 

65 

IF(I-7>  31,. 37, 30 

COH 

66 

30  I0T8Lll.,L0C)  = BITPUTIIDTBLHi,L0CI,I0IM(3l  ,361 

COH 

62 

37  IOTBLI4,LOCI:BITPUT(IOTBLI4,LOC),IOIM(7I ,181 

COH 

60 

34  IOTBLI3,LOC»*0ITPUT(IOTBLI3,LOC),IDIM(1)  ,361 

COH 

69 

40  IF(I0TBL(5,ICML0C)  .eg.  01  GO  TO  45 

COH 

70 

C»*  SET  POINTER  from  PREVIOUS  VARIABLE  TO  PRESENT  VARIABLE  IN 

COH 

71 

c»*  common  link 

COH 

72 

lOTBL  t5,LSTLOC  t*LOC 

COM 

73 

GO  TO  47 

COM 

76 

FIRST  VARIABLE  IN  BLOCK,  STORE  LOCATION  IN  SYMBOL  TABLE 

COM 

75 

45  lOTBL «5, ICMLOC)»L OC 

COM 

76 

C»»  RESET  COMMON  BLOCK  SIZE  AND  STORE 

COM 

77 

47  lOTBL 14, ICMLOC )«IDTBL (4, ICML OC i ♦ ICMS I Z 

COM 

70 

C»»  RESET  "LAST  VARIABLE  IN  BLOCK"  TO  PRESENT  VARIABLE 

COH 

79 

IOTBL«6,ICMLOO»LOC 

COM 

00 

C»*  STORE  COMMON  LOCATION  TO  ASSOCIATE  THIS  VARIABLE 

COH 

01 

C»»  NITH  THAT  COMMON  BLOCK 

COM 

02 

lOTBL  I6,L0C):ICML0C 

COM 

83 

LSTLOC=LOC 

COM 

06 

IFUIJPTR-K  .EQ.  COMMA*  GO  TO  77 

COH 

85 

IF(A(JPTR-1I  .NE.  SLASH*  GO  TO  50 

COH 

06 

C»»  END  OF  COMMON  BLOCK,  COMPLETE  COMMON  LINK 

COM 

87 

lOTBL  I5,L0CI  = I0TBL  (5,  ICMLOC* 

COH 

00 

GO  TO  15 

COH 

09 

50  IF  (NEXT!  JPTR*  .NE.  BLANK*  GO  TO  60 

COH 

90 

C»*  ENO  OF  COMMON  BLOCK,  COMPLETE  COMMON  LINJ< 

COM 

91 

lOTBL  «5.LOC*=  I0T8L  15,  ICMLOC* 

COM 

92 

RETURN 

COM 

93 

6 0 CALL  ERROR (7* 

COH 

96 

RETURN 

COM 

95 

80  call  ERR0RI14, NXTIO* 

COH 

96 

RETURN 

COM 

97 

ENO 

COH 

98 

SUBROUTINC  CONCHK 

COHCMK 

2 

COHMON  *<13?6I  ,0  fSaOl  t IDTRL<a,S00  1 t INiTIOm  ,L  tSTIOC  J) 

•ISRCH(3»t 

RICH 

2 

• JPTR.N.N,  JT»P,LST*BT,N2,  ifncnm,logio*n«  tio,  iotyp.nio. 

LOC, 

CY58A 

80 

Z ITYP,  ITYP.ISlKOT  .node  .ierr.iofs 

RICH 

4 

COMMON/LIST/NLIST  .NINIFC,  ISUBLT  (Z,Z00»  tIHTE»C(  300  1 

COMCHK 

4 

COPHON/r,LOB*t.  /NBLK.NREF,  NSUBS.BLKTBL  I Z 00  I , t « TT  BL  ( 1 00  ) , 

isuesf ioo> 

COHCMK 

5 

INTEGER  BITGt  T,CMBLK(Z,?OI  ,TP,SZ,  PREVTP,  BLKTBL 

COHCHK 

6 

integer  SESC0N(13I,SESERR 

COHCHK 

7 

OIPENSION  ITPS (61 ,I0R0  (61 

COMCHK 

8 

0«T0  I0R0/1.Z,B,<.,3.6/ 

COHCHK 

9 

DATA  SFSC0HAHCASE«3HINA  . 3HI  NB  t 3H INC • 3 HI  OK » 5 HN  PA  GX ,%HL  INX , 3H  10 Y, 

COHCHK 

10 

% 5HNPAGY,%HL1NY,3HI0^*5HNPAG^*4HL INZ/ 

COHCHK 

11 

C**  THIS  ROUTIME  IS  CALLED  AFTER  NOOULE  PROCESSING  TO  COHPLETE 

COHCHK 

1? 

THE  PROCESSING  OF  COHHON  BLOCKS 

COHCHK 

13 

SESERR»0 

COHCHK 

14 

NSES=0 

COHCHK 

15 

ICTGBZxO 

COHCMK 

16 

I8lK=INITI0(3t 

COHCHK 

17 

mOOCLSxO 

COHCHK 

18 

LCZ=BITGET(niBL  (3,ll,36tBI 

COHCHK 

19 

IFdCZ  .EO.  0 .OR.  IBLKOT  .EO.  1)  GO  TO  1 

COHCHK 

20 

NOOCLSxBlTGET  ( ISUBLKZ  .LCZI  ,10 .61 

COMCHK 

21 

1 IFdBLK  .EO.  01  GO  TO  IZO 

COHCHK 

22 

IF  (lOTBL  (1,  IBLKI  .EO.  IH  1 GO  TO  3 

COHCHK 

23 

C»»  GET  SESCONP  LIST  LOCATION  OF  CONHON  BLOCK 

COHCHK 

24 

LISTLCxBITGET ( IOTBL (3.IBLKI, 36.9) 

COHCHK 

25 

C»»  GET  COHNON  BLOCK  CLASS 

COHCHK 

26 

KLAS=BITGET(ISUBLT(Z,LISTlCI  .10,6) 

COHCHK 

27 

C»*  GET  COHHON  BLXK  SIZE 

COHCHK 

28 

ISI-eiTGETlISUBLT  (Z.LISTLO  , 30  , IS) 

COHCHK 

29 

C»»  CHECK  SIZE 

COHCHK 

30 

IFdOTBL  (6.IBLK)  ,NE.  IS7)  GO  TO  TO 

COHCHK 

31 

GO  TO  5 

COHCHK 

32 

C»»  BLANK  COHHON 

COHCHK 

33 

3 IF(HOOCLS  .HE.  1 .AND.  HOOCLS  .HE.  Z)  GO  TO  S 

COHCHK 

34 

C»»  IF  CLASS  1 OR  Z - CHECK  SIZE 

COHCHK 

35 

IBHKSZ<BITGET  (ISUBLT  (Z.LCZ).30,15) 

COHCHK 

36 

IFdOTBL(6,IBLK)  .NE.  IBHKSZ)  C ALL  ERROR  (SO  , ?H // ) 

COHCHK 

37 

$ NBLOC*0 

COHCHK 

38 

ISUHxO 

COHCHK 

39 

NTP»0 

COHCHK 

40 

TPiO 

COHCHK 

41 

ICOHST*IOTBL(5 ,IBLK) 

COHCHK 

42 

LOC*ICOHST 

COHCHK 

43 

10  PRfVTPxTP 

COHCMK 

44 

C»»  GET  TYPE  OF  next  variable  IH  COHHON  BLOCK 

COHCHK 

45 

IF(BITGET(I0TBL(3,LOC)  ,11,1)  .EO.  1)  GO  TO  IS 

COMCHK 

46 

TP«l 

COHCHK 

47 

IFSTxBITGETdOTBL  (l.LOC)  ,6,6) 

COMCHK 

48 

IFIIFST  .LE.  16  .ANO.  IFST  . GC . 9)  TP<6 

COHCHK 

49 

GO  TO  16 

COHCHK 

50 

IS  TPxBITGET(I0TBL(3,LX)  ,10.3) 

COHCHK 

51 

C**  GET  SIZE  OF  VARIABLE 

COHCMK 

52 

to  SZxl 

COHCMK 

53 

NO  IHxBITGET  (IOTBL  (3.LOC)  ,7,6) 

COHCHK 

54 

IF(NOIH  .EQ.  0)  GO  TO  ZZ 

COHCMK 

55 

00  ZO  I«l,NOIH 

COHCMK 

56 

NW*3»(I/2) 

COMCHK 

57 

ICOL-ie* IHOO( t •?! ♦!! 

COMCMK 

58 

^0  SZ*SZ*arTGeri tOT8lfNM«LOC) •IC0L«18) 

COMCMK 

59 

IfiTP  .NC«  z .AND.  TP  .NE*  31  GO  TQ  ^S 

COMCHK 

60 

C*«  DOUBLE  PRECISION  OP  CO»«*LEX  VARIABLE 

COMCHK 

61 

C**  CHECK  THAT  IT  BEGINS  ON  EVEN  LOCATION  MITHIN  COHHON  BLOCK 

COMCHK 

6Z 

IF  IHOO  IISUH,?I  .NE.  OICALL  ERR0RI6<>,  lOTBLtl  , LOCI 

.lOTBLIl.IBLKM 

COMCHK 

63 

ISO«=ISUH*SE 

COMCHK 

64 

25  1SUH*ISUN*S2 

COMCHK 

65 

C»»  CHECK  FOR  PROPER  ORDER  OF  VARIABLES  IN  BLOCK  DATA 

subroutine 

COHCHK 

66 

IFIIBLKOT  ,EQ.  1 .ANO.  I ORO« PRE VTP»1 1 ,GT.  IOR0(TP»lll 

COMCHK 

67 

$ CALL  fPROPieS  • lOTBL  a bIOLKU 

COMCHK 

68 

IFIKLAS  .EQ.  10  .OP«  I OT BL  fl  »I BL K ) .EO*  IH  ) GO 

TO  38 

COMCMK 

69 

IfCKLAS  .EQ*  91  GO  TO  3S 

COMCHK 

70 

IFIKLAS  bEQ.  n GO  TO  AO 

COMCHK 

71 

C**  CATEGORY  2 COWON  BLOCK  - CHECK  THAT  JT  IS  GROUPED 

BY  TYPE 

COMCHK 

72 

ICTGR2«1 

COMCHK 

73 

IFITP  bEOb  PREVTPI  GO  TO  39 

COMCHK 

74 

IFIPREVTP  «E3*  0)  GO  TO  32 

COMCHK 

75 

00  30  1*1, NTP 

COMCHK 

76 

IFITP  .EQ.  ITPSIIH  GO  TO  llO 

COMCHK 

77 

30  CONTINUE 

COMCHK 

78 

32  NTP*NTP»l 

COMCMK 

79 

ITPSiNTPIsTP 

COMCHK 

80 

C**  CHECK  THAT  VARIABLE  MAS  USED 

COMCHK 

81 

39  IFIIBLKOT  .EQ.  l>  GO  TO  38 

COMCHK 

82 

IFI6ITGETII0TBLI3, LOO  .38.11  «EQ.  0)  C AL  L E PRO  Rl  79 . 10  TBL 1 1 . LOC  U 

COMCHK 

83 

38  LOC>IOT6LI9.LOO 

COMCMK 

84 

IFILOC  .NE.  ICOHSTI  GO  TO  10 

COHCHK 

85 

GO  TO  69 

COMCHK 

86 

C**  CATEGORY  1 COWON  BLOCK  - STORE  VARIABLE  TYPES  ANO 

SIZES  BY  GROUP 

COMCMK 

87 

40  IFITP  .EQ.  PREVTP»  GO  TO  45 

COMCHK 

88 

NBLOCsNBLOCtl 

COMCHK 

89 

CHBLKll.NBLOO  =TP 

COMCHK 

90 

CHBLKI2.NBLX)  *0 

COMCHK 

91 

45  CHBLKI2.NBLOCI  «C  H8LK  <2 . NBL  OC  » ♦ S7 

COMCMK 

92 

IF  HOT  0L  ll.IBLKI  .NE.  6HSESC0N»  GOTO  85 

COMCHK 

93 

C**  CHECK  variables  IN  COMMON  BLXK  -SESCOH- 

COMCMK 

94 

NSES=NSES41 

COMCMK 

95 

IF  INSES  .GT.  1 3>  GO  TO  80 

COMCHK 

96 

IFIIOTBLII.LOCI  .EQ.  SESCOMINSESM  GO  TO  89 

COMCMK 

97 

80  SESERRsl 

COMCMK 

98 

85  LOC^IOTBL I5.L OC) 

COMCMK 

99 

IFILOC  .NE.  ICOHSTI  GO  TO  10 

COMCMK 

100 

C**  CHECK  INTERFACE  DEFINITION  FOR  COMMON  BLXK 

COMCHK 

ICl 

C**  GET  INTERFACE  DEFINITION  TABLE  POINTERS 

COMCHK 

102 

IPTRsBlTCETlISUBLT  I2.LISTLO  .60.121 

COMCHK 

103 

N0PTR«IPTR^INBL0C-1) /3 

COMCHK 

104 

KOUNTsQ 

COMCHK 

105 

NGRP*NRLX 

COMCHK 

106 

C**  these  TMO  loops  CHECK  THE  INTERFACE  DEFINITION 

COMCMK 

107 

00  50  i*iptr,noptr 

COMCHK 

108 

ICOLS8 

COMCHK 

109 

DO  50  Jsl.3 

COMCHK 

110 

KOUNTsKOUNT^I 

COMCHK 

ill 

IFIKOUNT  .GT.  N6L0CI  GO  TO  65 

COMCMK 

112 

TCOL*ICOL^17 

COMCHK 

113 

,’h 


C»*  GfT  CROUP  Size 

COHCHK 

114 

SZ'BITGET  IINTFACI  II  t ICOLi  III 

COHCHK 

115 

ICOt*ICOL*3 

COHCHK 

116 

C»*  GET  GROUP  TYPE 

COHCHK 

117 

TPseiTGETIINTFACf II* ICOLf 31 

COHCHK 

118 

IFITP  .NE*  0)  GO  TO  46 

COHCHK 

119 

CMBLK(?*KOUNTI  «C HBCK ( ? *K OUNT 1 -S 7 

COHCHK 

1?0 

IFCCHBLK(7,K0UNTI  .EQ*  01  GO  TO 

50 

COHCHK 

171 

IF fCN9LKC?,K0UNTI  *LT*  01  GO  TO 

90 

COHCHK 

1?7 

KOUNT«KOUNT-l 

COHCHK 

173 

NGRPsNGRP»l 

COHCHK 

174 

GO  TO  50 

COHCHK 

175 

C**  CHECK  INTERFACE  DEFINITION  FOR  SI?E  AND  TYPE 

COHCHK 

176 

<•8 

IFfCHBLK(l,KOUNT)  *NE*  TP  .OR* 

CM6LKI?,K0UNTI  .NE.  S7I 

GO  TO  90 

COHCHK 

177 

50 

CONTINUE 

COHCHK 

176 

IFCNGRP  *NE*  BITGET  USUBLT  (3,LISTLCI  *6,6  II  GO  TO  90 

COHCHK 

179 

6S 

leLK^IOTBL (?« IBLKI 

COHCHK 

130 

GO  TO  1 

COHCHK 

131 

TO 

CALL  ERR0R(58*  lOTBLdf  IBLKI) 

COHCHK 

137 

GO  TO  55 

COHCHK 

133 

90 

CALL  ERROR(57« I0T6L Cl* IBLKII 

COHCHK 

134 

GO  TO  65 

COHCHK 

135 

110 

CALL  ERRORC63 * IDTBL <1* IBLKII 

COHCHK 

136 

GO  TO  65 

COHCHK 

137 

C**  CHECK  that  CONHON  BLOCK  “SESCOH- 

IS  HELL  OEFINFO 

COHCHK 

138 

1?0 

IFCICTGR7  .EQ*  0 .ANO.  IMOTCLS 

.EO.  1 .OR.  NOOaS  .EO. 

?l  I 

COHCHK 

139 

S CALL  ERRORC73I 

COHCHK 

140 

IFCNSES  .EQ.  01  GO  TO  130 

COHCHK 

141 

IFCSESERR  .EQ«  1 .OR*  NSES  .LT. 

131  call  error  «>8I 

COHCHK 

147 

return 

COHCHK 

143 

130 

CALL  ERRORC66I 

COHCHK 

144 

RETURN 

COHCHK 

145 

END 

COHCHK 

146 

SUBROUTINE  CONFXT 

COHEXT 

2 

COHHON  All J?6I •0<500»  f IOTBLI At SOO ( , INITI 0<3I «L  ASTIOf  31 , ISRCHI3) • 

RICH 

2 

• JPT«?*N,N,  JTYP,LSTART*N2,  IFNCNH,LOGIO*NKTIO*IOTYP.NIO,LOC* 

CY5  8A 

80 

2 LTYP, ITYP.IBLKOT ♦HOOE*IERR,IOFS 

RICH 

4 

INTEGER  flITGFT 

COHEXT 

4 

C»»  THIS  ROUTINE  CHECKS  TO  SEE  IE  AN  EQUIVALENCE  STATEMENT 

COHEXT 

5 

EXTENDS  COMHON 

COHEXT 

6 

ICOMLC  = 0 

COHEXT 

7 

C**  GET  COHHON  INFORHATION  FROH  SYHBOL  TABLE 

COHEXT 

0 

IC0HNH=I0TBU6  tL  OC» 

COHEXT 

9 

ICOMSTsIOTBLIS • ICOHNHI 

COHEXT 

10 

ICOHNO  = IOTBLI6  « ICOHNHI 

COHEXT 

11 

ICOHSZ*IOTBtm»  tCOHNH) 

COHEXT 

12 

nxtloc*icohno 

COHEXT 

13 

€••  this  loop  cohputes  the  nuhber  of  cchhon  locations 

TO  THE  LEFT  OF 

COHEXT 

14 

c**  the  fouivalenceo  variable 

COHEXT 

15 

00  20  I*l*IC0HS7 

COHEXT 

16 

NXTL0C=I0TBU5  tNXTLOC) 

COHEXT 

17 

HUL«1 

COHEXT 

18 

ISZsl 

COHEXT 

19 

C**  GET  VARIABLE  TYPE 

COHEXT 

20 

ITPsBITCETlI0TBLI3»NXTL0C»  *10, 31 

COHEXT 

21 

C**  IF  COHPLEX  OR  OOU8LE  PRECISION,  SET  HULTIPLIER  TO 

2 

COHEXT 

22 

IFCITP  .EQ,  2 .OR.  ITP  .EO,  3)  HUL=2 

COHEXT 

23 

IFILOC  ,EQ,  MXTLOC)  GO  TO  25 

COHEXT 

24 

IFI6ITGET1IOT6L(3,NXTLOCI ,1,11  .EQ.  11  G0  TO  10 

COHEXT 

25 

C**  NON-OIHENSIONEO  VARIABLE 

COHEXT 

26 

GO  TO  20 

COHEXT 

27 

10  NOIH«BITGET  CIOTBL  C3,NXTLOC»,r,6) 

COHEXT 

28 

C**  OmNSlONEO  variable  - GET  SIZE  OF  ARRAY 

COHEXT 

29 

00  15  J«l,NOIH 

COHEXT 

30 

INR0=3^J/2 

COHEXT 

31 

IPOS*  CHOOU,2I  ♦D^IS 

COHEXT 

32 

IS2*ISZ*BITGET  (IOTBHINRO,NXTlOCI  .IPOS.l  81 

COHEXT 

33 

15  CONTINUE 

COHEXT 

34 

20  ICOHLC*ICOHLC^  ISZ*HUL 

COHEXT 

35 

25  ILFTxiCOHLC 

COHEXT 

36 

C»*  COHPUTE  NUHBER  OF  COHHON  LOCATIONS  TO  THE  RIGHT  OF 

THE 

COHEXT 

37 

c**  fouivalenceo  variable 

COHEXT 

38 

IRHT*ICOHSZ-ICOHLC 

COHEXT 

39 

NXTLOC*LOC 

COHEXT 

40 

C»*  GET  OFFSET  OF  FOUIVALENCEO  VARIABLE 

COHEXT 

41 

IOFFST*IOT6LIO,NXTLOC) 

COHEXT 

42 

30  NXTL0C*I0TBLI7,NXTL0CI 

COHEXT 

43 

IFINXTLOC  .EO.  LOC)  RETURN 

COHEXT 

44 

C»»  GET  OFFSET  OF  NEXT  VARIABLE  IN  EQUIVALENCE  LINX 

COHEXT 

45 

IOFF2*IOTBLfS,NXTLOCI 

COHEXT 

46 

C**  CMECX  TO  SEE  IF  COHHON  NAS  EXTENOEO  TO  THE  LEFT 

COHEXT 

47 

IF(IIOFFST-IOFF2l  *GT,  ILFTI  GO  TO  50 

COHEXT 

48 

ITPxBITGETlIOTBL l3fNXTLOCI flOt  31 

COHEXT 

49 

ISZ«1 

COHEXT 

50 

IFIITP  ,NE.  2 .AND.  ITP  ,NE,  31  GO  TO  32 

COHEXT 

51 

f IF  VARIABLE  IS  COMPLEX  OR  DOUBLE  PRECISION,  CHECX 

that  IT  BEGINS 

COHEXT 

52 

C**  ON  AN  EVEN  LOCATION  NITHIN  COHHON  BLOCX 

COHEXT 

53 

IF IHOO  If ILFT-I OFFST^IOFFZI ,21 .NE.  OJ  CALL  ERROR  164, lOTBL 11 ,NXTLOCI> 

COHEXT 

54 

ISZ*2 

COHEXT 

55 

12  IF  (6ITGETI  IOTBL(3,NVTLOCI  ,1,11  ,NE.  11  GO  TO  40 

COHEXT 

56 

"1 


NOIH-SITCET  (IOT0L  (3,NKTL0CI.  7,6> 

CONEXT 

57 

C»*  OlfCMSIOfCO  VAPIABLE  - GET  SIZE  OF  •RRAY 

CONEXT 

50 

00  39  I«1,N0IH 

COHEXT 

59 

IWR0=3^I/? 

CONEXT 

60 

IPOS*  CHOO<I*ZI ♦!! •!» 

COHEXT 

61 

ISUB*eiTGET(IOTBl ( IMRO«NXTLOC>  «IPOSt 10) 

COHEXT 

6Z 

isz«isz*isue 

COHEXT 

63 

3S  continue 

COHEXT 

64* 

C**  CHECK  TO  SEE  IF  COHHON  NAS  EXTENDED  TO  THE  RIGHT 

COHEXT 

65 

^0  IFUISZ-IIOFFST-IOFFZM  ,GT.  IRHTI  GO  TO  50 

COHEXT 

66 

GO  TO  30 

COHEXT 

67 

50  CALL  ERROR(%7) 

COHEXT 

60 

RETURN 

COHEXT 

69 

END 

COHEXT 

70 

subroutine  cohsch 

COHSCH 

2 

COHHON  AI13Z6I  « 0 ( 500 ) « lOTBL < 0 *5 00 1 • INITI Cl3*  ?L  AS TlO( 3 ) , tSRCH m « 

RICH 

2 

• JPTR,N,H, JTtP ♦tSTART  »HZ , If HCNH,LOC10 *HX T1D, 10 T?P*NI 0 tLOC f 

CY5BA 

60 

2 LTYP, ITYP*I8LK0T.H00E*IERRfI0ES 

RICH 

«» 

THIS  ROUTINE  SEARCHES  THE  SVP«OL  TABLE  FOR  A COHHON  JLOCK  NAHE 

COHXH 

4* 

C**  AND  RETURNS  ISRCH<3I*1  - FOUND  *0  - NOT  FOUND 

COHSCH 

5 

C*«  LOC  - SYHBOL  TABLE  LOCATION  NHERE  NAHE  NAS  FOUND 

COHSCH 

6 

J*INITIOC3» 

COHSCH 

7 

IFfJ  .EQ«  0)  GO  TO  15 

COHSCH 

0 

00  10  I«l*HIO 

COHSCH 

9 

IF (lOTBL fl* Jl  «NE.  NXTIO)  GO  TO  5 

COHSCH 

11 

ISRCHf  3)  «1 

COHSCH 

11 

LOC-J 

COHXH 

12 

RETURN 

COHSCH 

13 

5 J«IOTBL(?*Jl 

COHSCH 

16 

IFU  .EO.  01  GO  TO  15 

COHSCH 

15 

to  CONTINUE 

COHXH 

16 

15  ISRCHOI  >0 

COHSCH 

17 

RETURN 

COHXH 

16 

END 

COHXH 

19 

1 


i 

1 


subroutine  cigoto 

COMHON  A(13?6)«0(SOQ)«IOTBU(S,SOQ>,INITlO<3)«tASTIom«  ISRCH(3  >• 
• JPTR,N,H, JTYP*L START ,N?, IENCNH.LOGID*  NX  T 10*  10  TYP*NIOt  LOG  t 
2 ITTP, ITYP, TBLKOT ,HOOE ,IERR* lOFS 
COHHON/L ABELS/ST ATRA  f ? , 2 0 0 ) * Nt ABEL 
COHHON/BAS8LK  / IBLOC»(C?S0O)  , NBL  OCK  .NB  ,NBR  NCH 
01  HENS  I ON  IALPH(I») 

INTEGER  STATRA.A, BLANK, RPARtCOMHA 
INTEGER  BITPUT.BITGET 

DATA  0LANK/1M  / , C OHNA / IM , / ,L PA R/ 1 HI /,  RPA R/1 H » / 

DATA  I lALPHlI  ) ,Isl,4)/lHG,lH0, IMT,1H0/ 

C**  COHPUTEO  CO  TO  STATEMENT  PROCESSOR 
00  5 I»1,A 

ifinekT(jptr)  ,ne,  ialphiii)  go  to  30 
5 CONTINUE 

IF INEXT ( JPTR)  .NE.  LPAR)  GO  TO  30 
NBLOCKaNBL 0C<  ♦ 1 
J8L0CKSN9L0CK 
NBPNCH*  0 

C**  GET  next  statement  LABEL 
10  CALL  GNLE 

IFIJTYP  ,NE.  SI  GO  TO  30 

C**  SEARCH  STATEMENT  NUMBER  TABLE  ANO  SET  -GOTO^  FLAG 
CALL  STSRCH 

ST  ATRA  1 2,  LOCI  *01  T PUT  (STATRA(2,LOCI,l,12l 
IFINBRNCH  ,EO.  0 1 GO  TO  IS 
C**  CHFCK  FOR  POSSIBLE  DUPLICATE  BRANCHES 
00  12  I=l,NBRNCH 

IFCLOC  .EO.  IBL0CK(NBL0CK*I^1II  go  TO  17 
1 2 CONTINUE 

C**  STORE  BRANCH  IN  BASIC  BLOCK  TABLE 
IS  NBLOCK=N0LOCK» 1 

IRLOCK (N8L0CKI »L OC 
C**  increment  branch  COUNTER 
NBRNCHsNBRNCH^ I 

17  TFINFXTUPTRI  .EO.  COMMA)  GO  TO  10 
IF(AIJPT9-1)  .NE.  RPAR)  GO  TO  30 
IF  (Nf  XT(  JPTR)  .NF.  COMMA)  GO  TO  30 
C**  GET  VARIABLE  REFERENCE 
CALL  GnlE 

IF  IJTYP  .NE.  21  GO  TO  30 
C**  GET  SYMBOL  TABLE  LOCATION 

call  sfarch 

IFIISRCMI2)  .EO.  1)  call  E RROP ( 1 0 , NXT I 0) 

IFUSRCHIl)  ,EQ.  1)  GO  TO  20 

iotyp*i 
CALL  STOOE 
LOC=NIO 

C**  CHFCK  that  reference  IS  INTEGER  VARIABLE 
20  CALL  IHPTYP 

IF  IBITGET  I IOTBL  I 3,LOCI  ,1  0,  3)  . Nt  . 4)  CALL  ERRO  R I 39  ,NXT  1 0> 

IF  IBITGETI  IOTBL  (3,LOCI  ,1  ♦ 1 1 .EO.  1»  CALL  E RROR  11  4 , NX  T I 0) 
IFINrXTIJPTRI  .Nf.  BLANK)  GO  TO  30 
C**  STORF  PEFFRENCE  IN  BASIC  BLOCK  TABLE 
IBLOCK  IJ BLOCK )»200Q*LOC 
N0*1 
Pf  TURN 

30  call  EPRORCT) 

RF  TURN 
END 


CTGOTO 

2 

RICH 

2 

CY5  8A 

80 

RICH 

4 

CTGOTO 

4 

CY58A 

28 

CTGOTO 

6 

CTGOTO 

7 

CTGOTO 

8 

CTGOTO 

9 

CTGOTO 

10 

CTGOTO 

11 

CTGOTO 

12 

CTGOTO 

13 

CTGOTO 

14 

CTGOTO 

15 

CTGOTO 

16 

CTGOTO 

17 

CTGOTO 

18 

CTGOTO 

19 

CTGOTO 

20 

CTGOTO 

21 

CTGOTO 

22 

CTGOTO 

23 

CTGOTO 

24 

CTGOTO 

25 

CTGOTO 

26 

CTGOTO 

27 

CTGOTO 

26 

CTGOTO 

29 

CTGoro 

30 

CTGOTO 

31 

CTGOTO 

32 

CTGOTO 

S3 

CTGOTO 

34 

CTGOTO 

35 

CTGOTO 

36 

CTGOTO 

37 

CTGOTO 

38 

CTGOTO 

39 

CTGOTO 

40 

CTGOTO 

41 

CTGOTO 

42 

CTGOTO 

43 

CTGOTO 

44 

CTGOTO 

45 

CTGOTO 

46 

CTGOTO 

47 

CTGOTO 

46 

CTGOTO 

49 

CTGOTO 

so 

CTGOTO 

51 

CTGOTO 

S2 

CTGOTO 

S3 

CTGOTO 

S4 

CTGOTO 

55 

CTGOTO 

S6 

CTGOTO 

S7 

CTGOTO 

58 

CTGOTO 

S9 

U) 


subroutinf  data 

OATA 

2 

COHHON  All3?6)tO(500)tIOTBL(St^OO)«INITID<31,LASTIO(SI ,ISRCH(3 1 • 

RICH 

2 

• JPTR,N,H,jTYP*LSTART,fC,  IFNCHH.LOCIO,  NX  TIO,  lOTYP 

,NI0,10C, 

CY58A 

80 

Z LTVP,  ITYP,  lamOT  ,N00E  tlERR.  lOFS 

RICH 

k 

OIHENSION  IALPHC4) 

OATA 

k 

INTEGER  A,RPAR,C0HHA,SLASH.BLANK,  ASTRIK,  PI.  US 

OATA 

5 

INTEGER  BITPUT ,6ITGET 

OATA 

6 

0»T»  LP*»/lH(/,RP»R/lHI/,COMM»/lH,/,SLASH/lH//,BL»N1t/lH  /, 

OATA 

7 

1 ASTRIK/IH*/ ,PLUS/1H^/,HINUS/1H-/ 

OATA 

8 

DATA  (lALPHm  ,Isl«<»)/tHO*lMA,lHT«lHA/ 

OATA 

R 

c** 

OATA  STATENENT  PROCESSOR 

data 

10 

00  S I«l»<» 

OATA 

11 

IF(NEXT(JPTR)  «NE.  lALPHlIM  GO  TO  GO 

DATA 

12 

S CONTINUE 

OATA 

13 

6 LST1SZ=0 

OATA 

14 

LSTZSZ*0 

DATA 

15 

8 ISZ»l 

DATA 

16 

c** 

GET  NEXT  VARIABLE  NAME 

data 

17 

CALL  GNLE 

data 

16 

IFiJTTP  .NE,  21  GO  TO  60 

OATA 

IR 

c** 

STORE  IN  SYMBOL  TABLE 

DATA 

20 

CALL  SEARCH 

DATA 

21 

IF(ISRCH«?J  .EQ.  11  call  E PROP ( 1 0 * NX T I0> 

OAT  A 

22 

IFlISRCHm  .EQ.  l»  GO  TO  R 

OAT  A 

23 

lOTtPri 

OATA 

24 

CALL  STORE 

DATA 

25 

LOC*NIO 

OAT  A 

26 

R IF  IBITGET  « IDTBL  (3,L0CI  ,12,11  .EQ.  11  C»Ll  E RPO  R(  5 0 , NXT  I 01 

data 

27 

c** 

SET  TYPE 

DATA 

26 

CALL  IMPTYP 

data 

2R 

IF(BITGETII0TBL(3,L0C) fl6«l>  «E0.  0)  GOTO  10 

OATA 

30 

c** 

VARIABLE  IN  COMMON  - MUST  BE  BLOCK  DATA  SUBPROGRAM 

DATA 

31 

c** 

MUST  ALSO  BE  LABELLED  COMMON 

DATA 

32 

ICOMLC:IOTBL(6«LOC1 

OATA 

33 

IFaSLKOT  .EQ.  0 .OR.  lOT 8L C 1 . IC OMLC 1 ,EQ.  BLANK) 

CALL  EPROR(28, 

OATA 

34 

•NXTiOl 

DATA 

35 

10  IF (NEXT ( JPTR)  .NE.  LPAR)  GO  TO  25 

DATA 

36 

IFIBITGETUOTBLO.LOC)  .1,1)  .EQ.  0)  GO  TO  RO 

DATA 

37 

c** 

SUBSCRIPTED  VApIABLE  - GET  NO.  OF  DIMENSIONS 

data 

36 

N0IM=8lT&ETa0TBL(3,L0C)  .7,6) 

data 

3R 

c** 

THIS  LOOP  CHECKS  THE  SUBSCRIPTS  AGAINST  THE  ACTUAL 

DIMENSIONS 

OATA 

40 

c** 

TO  CHECK  their  VALIDITY 

DATA 

41 

1*0 

OAT  A 

42 

15  I=I»1 

DATA 

43 

CALL  GNLE 

OAT  A 

44 

IF  UTYP  .NE.  5)  GO  TO  60 

DATA 

45 

IF(N2  .LE*  0)  call  ERROR(S) 

DATA 

46 

IMRO*3«I/2 

OATA 

47 

IPOSrl«*MOOa  . 2)  ♦!$ 

DATA 

46 

IFCN2  .GT.  BITGET  < lOTBLI  IMRO.  LOC ) , I POS,  1 8)  ) CALL 

ERRORlia) 

DATA 

4R 

IF (NEXT ( JPTR)  .EQ.  COMMft)  GO  TO  15 

DATA 

50 

IF  (I  .NE.  NOIM)  GO  TO  80 

DATA 

51 

IFUUPTR-l)  .NE.  RPAR)  GO  TO  80 

OATA 

52 

GO  TO  35 

OATA 

53 

c** 

NON-SUBSCRIPTEO  VARIABLE 

OATA 

54 

25  JPTR=JPTR-1 

DATA 

55 

IF  fBITGETnOTBL(3.LOC)  .1.1)  .EQ.  0)  GO  TO  35 

OATA 

56 

C*»  »RP»T  NAME 

DATA 

57 

N01M  = aiTGET(I0T8L(3,L0C),7.6» 

data 

58 

c**  this  loop  calculates  the  site  of  the  array 

DATA 

59 

00  30  I=1,N0IM 

data 

60 

IMRn=3»I/2 

DATA 

61 

IP0S=1  B’MOO  II  , 2)  ► 18 

data 

6Z 

3 3 IS7*IS7»0ITGET  IIOTBL  lIHRO.LOCI  . IPQS.IB* 

DATA 

63 

IF  (BITGET  1 10T8L  (3,L0C1  fl4,l»  .FO.  1»  CALL 

ERPORIZ9, IOTBL  11, LOO) 

data 

64 

C*‘  INCREMENT  variable  LIST  SIZE  BY  APPROPRIATE 

AMOUNT 

DATA 

65 

3S  LSTISZ=LST1SZTISZ 

DATA 

66 

C»»  SET  -OATA~  FLAG 

DATA 

67 

IOTBL  (3,L0Ct  = BITPUTI  IOTBL  1 3,L0C»  , 1, 14) 

DATA 

68 

IF  INf  XT  I JPTRI  .EO.  COMMA)  GO  TO  B 

DATA 

69 

IFIA(JPTR-l)  .NE.  SLASH)  GO  TO  60 

data 

70 

C»*  SLASH  ENCOUNTERED  - END  OF  VARIABLE  LIST 

data 

71 

40  NRPEAT=1 

OAT  A 

7Z 

CALL  GNLE 

data 

73 

C"  GET  NEXT  constant 

DATA 

74 

IF  1 JTYP  ,EQ.  3)  GO  TO  47 

DATA 

75 

IFIJTYP  .NE.  5)  GO  TO  45 

DATA 

76 

C**  INTEGER  - HAY  BE  A REPEAT  COUNT 

data 

77 

IFINEXTIJPTR)  .NE.  ASTRIX)  GO  TO  50 

DATA 

78 

C»*  REPEAT  COUNT  - SET  VALUE 

DATA 

79 

NR  PEAT=NZ 

DATA 

80 

C*’  GET  next  constant 

data 

81 

CALL  GNLE 

OAT  A 

8Z 

c»*  constant  may  be  preceoeo  by  plus  or  minus 

DATA 

83 

45  IFIAIJPTR-I)  .NE.  PLUS  .ANO.  AIJPTR-l)  . NE . MINUS)  GO  TO 

47 

data 

84 

C»*  PLUS  OR  MINUS  FOUND,  GET  NEXT  CHARACTER 

DATA 

85 

CALL  GNLE 

DATA 

86 

47  KX  = NEXT  ( JPTR) 

data 

87 

50  IFIJTYP  .GE.  3. ANO.  JTYP  .LE.  6)  GO  TO  55 

DATA 

88 

IFIJTYP  .EO.  7 .AND.  ILOGIO  .EO.  10  .OR. 

LOGID  .EQ.  ID) 

GO  TO  35 

OAT  A 

89 

GO  TO  70 

DATA 

90 

55  LSTZSZ*LSTZS7*NRPEAT 

DATA 

91 

C»*  INCREMENT  CONSTANT  LIST  SI7F 

DATA 

9Z 

IFIAIJPTR-1)  .EO.  COMMA)  GO  TO  40 

DATA 

93 

IFIAIJPTR-1)  .NE.  SLASH)  GO  TO  60 

DATA 

94 

C»»  COMPARE  SIZE  OF  CONSTANT  LIST  MITH  SIZE  OF 

VARIABLE  LIST 

data 

95 

IFILSTISZ  .NE.  LSTZSZ)  CALL  ERRORI31) 

DATA 

96 

IFINEXTIJPTR)  .EO.  COMMA)  GO  TO  6 

DATA 

97 

IFIAIJPTR-1)  .NE.  PLANK)  GO  TO  60 

DATA 

98 

RE  TURN 

DATA 

99 

60  CALL  ERR0RI7) 

DATA 

100 

RETURN 

DATA 

101 

70  CALL  ERRORIZ3) 

DATA 

ICZ 

RETURN 

DATA 

103 

»0  CALL  ERRORI19) 

DATA 

104 

PE  TURN 

DATA 

105 

90  CALL  ERROPI13,  IOTBL  11, LOC)  ) 

DATA 

106 

PE  TURN 

DATA 

107 

END 

DATA 

108 

SUBROUTINE  OeSCRP 

oescRp 

z 

COMMON  « (13?6)  .0  (5S0)  .IDTBKS.SOOI  iINITIDO)  ,L  RSTIOC3I , ISRCH(3  1, 

RICH 

z 

• JPTR.N.N,  JTrP.LSTdRT,  N?,  IFNCNM,  LOGIO.NXTIDt  10  TY  P,  NIDt  LOC  , 

CY5  e* 

80 

z ltyp, ityp, iblkot.mooe.ierr, iofs 

RICH 

4 

C0HM0N/F0RM»T/  ioesst.ioesnd.igpsT.icpno,  igrp  .sepst  ,sepno. 

CV58A 

5 

1 DIR, icon, ISEP 

orscRp 

S 

OIMENSION  FORMlm 

OESCRP 

6 

INTEGER  *,FORMT,OECPT,BL»Nit,PEE,EX,*ICH 

OFSCRP 

7 

0*T»  «FORNT  «I  ) ,I*1,7I/1HF,  IHE.IHG.IHO.IH  1,1  ML,  1H»/ 

orscRP 

6 

0*TA  0ECPT/1H,/,BL»NK/1H  / ,PEE /IMP/ ,E  X /I  MX/ , »I  CM/ 1 HM/ , MINUS  / 1M-/ 

oescRP 

9 

c»»  tmis  routine  checks  tme  syntax  of  a field  descriptor  ano  returns 

OESCRP 

10 

C»»  IDES=1  - valid 

OFSCRP 

11 

C*»  I0ES«0  - INVALID 

OFSCRP 

tz 

ISCLFC=0 

OFSCRP 

13 

INT«0 

OESCRP 

14 

IMINUS=0 

OFSCRP 

IS 

I0ES*1 

OESCRP 

16 

IF  »NEXT(I0ESST»  ,NE.  MINUS)  GO  TO  S 

OESCRP 

17 

C»*  MINUS  SIGN  FOUND,  SCALE  FACTOR  SMOULD  FOLLOW 

OESCRP 

18 

IMINUS*! 

OESCRP 

19 

GO  TO  6 

OFSCRP 

20 

s jptr=ioesst 

OFSCRP 

21 

6 CONTINUE 

OFSCRP 

22 

CALL  GNLE 

OFSCRP 

23 

IFIJTYP  ,EQ.  3)  GO  TO  80 

OESCRP 

24 

IFCJTYP  ,EQ,  5)  GO  TO  10 

OESCRP 

25 

IFUTYP  ,NE.  7)  GO  TO  15 

OFSCRP 

26 

IFINXTID  ,EQ.  PEE  .AND.  ISCLFC  .EQ.  0)  GO  TO  20 

OFSCRP 

27 

IFIINT  ,EO.  1 .ANO.  N2  ,LT.  11  GO  TO  15 

OESCRP 

28 

IFIISCLFC  .EO,  0 .ANO.  IMINUS  .EO,  1)  GO  TO  15 

OESCRP 

29 

GO  TO  25 

OESCRP 

SO 

10  INT»1 

OFSCRP 

31 

GO  TO  6 

OFSCRP 

32 

C»»  INTEGER  FOUNO 

OESCRP 

33 

15  IOES=0 

OFSCRP 

34 

RETURN 

OESCRP 

35 

20  IFIINT  .EQ.  01  GO  TO  15 

OESCRP 

36 

C»*  scale  factor  FOUNO 

OFSCRP 

37 

ISCLFC=1 

OFSCRP 

38 

INT«0 

OFSCRP 

39 

GO  TO  6 

OFSCRP 

40 

C»*  GET  TYPE  OF  FIELD  DESCRIPTOR 

OFSCRP 

41 

25  DO  30  1*1,7 

OFSCRP 

42 

IFCNXTIO  .EO.  FORNTCD)  GO  TO  <»5 

OESCRP 

43 

30  CONTINUE 

OESCRP 

44 

IFINXTID  .NE.  EX  .OR.  ISCLFC  .EO.  1 .OR.  INT  .EO.  0)  GO  TO  15 

OESCRP 

45 

GO  TO  80 

OFSCRP 

46 

<>5  CALL  GNLE 

OESCRP 

47 

C»»  GET  FIELD  width 

OFSCRP 

48 

IFIJTYP  .NE.  5)  GO  TO  15 

OESCRP 

49 

NWIDTH*N2 

OESCRP 

50 

IFII  ,LE.  NI  GO  TO  60 

OFSCRP 

51 

c»*  field  type  is  i.l,  or  a 

OESCRP 

52 

IFIISCLFC  .EO.  1 .OR.  NWIDTK  .LT.  1 .09.  II  .EO.  7 .AND.  NWIOTM 

OESCRP 

53 

t .GT.  1.)  1 GO  TO  15 

OESCRP 

54 

IOESNO*JPTR-1 

OESCRP 

55 

RE  turn 

OESCRP 

56 

C»*  FIELD  TYPE  IS  F.E.G  OR  0 

OFSCRP 

57 

60  IF INEXT IJPTRI  .NE.  DECPT ) GO  TO  15 

OFSCRP 

58 

IFINWIDTM  .LT.  21  GO  TO  15 

OFSCRP 

59 

CALL  GNLE 

OFSCRP 

60 

IFIJTYP  .NE.  5)  GO  TO  15 

OFSCRP 

61 

C»*  GET  number  of  decimal  PLACES 

OFSCRP 

62 

N0CPLS*N2 

OFSCRP 

63 

IOESNO«JPTR-l 

OFSCRP 

64 

IFII  .EQ.  1)  GO  TO  65 

OFSCRP 

65 

C**  CHECK  VALIDITY  OF  FIELD  DESCRIPTOR  SITE 

OESCRP 

66 

IFINWIOTM  .LT.  IN0CPLS*6)I  GO  TO  15 

OFSCRP 

67 

RETURN 

OFSCRP 

68 

65  IFINWIOTM  ,lT.  NOCPLSI  go  TO  15 

OFSCRP 

69 

RETURN 

OFSCRP 

^8 

80  IOESNO*JPTR-l 

OFSCRP 

71 

RETURN 

OFSCRP 

72 

END 

OFSCRP 

73 

SUUROUTINE  OIHEM 

OTMEN 

3 

COMMON  « (13361  ,0  (500l,IOT8L(«.500l,IMITIO(3»,t.*STIO(3»,  ISRCHI3I, 

RICH 

3 

• JPTR,N,M,JTYP,LST»PT,N3,  ifncnm.logio.nxtio,  IOTVP.NIO,  loc. 

CY5  8A 

80 

3 LTTP,  ITYP,  IBL  KOT,  MODE,  r ERR.  IDES 

RICH 

4 

DIMENSION  IALPM(9)  , IOIM(  3» 

OIMEN 

4 

INTEGER  A.O.RPAR.COMM* 

OIMEN 

5 

INTEGER  0ITPUT  .BITGET.COMLOC 

OIMEN 

6 

DATA  (lALPHdl  ,I  = l,qt/lHO,lHI,lMM,lHE,lMN,lHS,  IHI.IMO.IHN/ 

OIMEN 

7 

DATA  LPAR/1H(/ ,RPAP/  1M» / , COMMA /I M, / 

OIMEN 

8 

C»»  DIMENSION  statement  PROCESSOR 

OIMEN 

9 

C»»  CHECK  SPELLING 

OIMEN 

10 

DO  10  1*1,9 

OIMEN 

11 

IF  (NEXT(  JPTR»  .NE.  lALPH(Il)  GO  TO  110 

OIMEN 

13 

10  CONTINUE 

OIMEN 

13 

C»»  GET  NEXT  DIMENSIONED  VARIABLE  ANO  STORE  IN  SYMBOL  TABLE 

OIMEN 

14 

13  CALL  GNLE 

OIMEN 

15 

IF(JTYP  .NE.  31  GO  TO  110 

OIMEN 

16 

CALL  SEARCH 

OIMEN 

17 

IF(ISRCH(3>  .EQ.  1»  call  ERROR  ( 10  ,NXT  IDt 

OIMEN 

18 

IF(ISRCHd)  .EO.  1)  GO  TO  5 

OIMEN 

19 

I0TYP=1 

OIMEN 

30 

CALL  STORE 

OIMEN 

31 

LOC=NIO 

OIMEN 

33 

C*’  IF  PREVIOUSLY  DIMENSIONED.  ISSUE  DIAGNOSTIC 

OIMEN 

33 

5 IF  (BITGE  TdOTBL  ( 3.LOCI  ,1,  It  .NE.  0>  CALL  ERROR  (11  , NXT  ID) 

OIMEN 

34 

C»*  SET  TYPE 

OIMEN 

35 

CALL  IMPTYP 

OIMEN 

36 

C**  SET  -OIMENSIONf  0"  FLAG 

OIMEN 

37 

IOTBL(3,LOC»  = BlTPUT(IOT0L(3,LOC),l,lt 

OIMEN 

38 

IE*LX 

OIMEN 

39 

IF(NtXT(JPTR(  .NE.  LPAR)  go  TO  110 

OIMEN 

30 

INCR=1 

OIMEN 

31 

1*0 

OIMEN 

33 

15  1*1*1 

OIMEN 

33 

C»»  GET  NEXT  DIMENSION 

OIMEN 

34 

CALL  GNLE 

OIMEN 

35 

IF (JTYP  .NE.  5»  GO  TO  13 

OIMEN 

36 

C»*  DltCNSION  IS  A constant,  CHECK  SIZE 

OIMEN 

37 

IOIM(I»*N3 

OIMEN 

38 

IF  (N3  .GT.  (3**ir-ll  .OR.  N3  .LE.  0)  CALL  ERROR(8» 

OIMEN 

39 

INCR=INCR»N3 

OIMEN 

40 

GO  TO  1*» 

OIMEN 

41 

13  IF(JTYP  .NE.  31  GO  TO  110 

OIMEN 

43 

C*»  variable  dimension,  store  in  symbol  table  ANO  CHECK  validity 

OIMEN 

43 

iotyp*i 

OIMEN 

44 

CALL  search 

OIMEN 

45 

IF(ISRCH(3»  ,NE,  0»  call  ERROR ( 10 .NXTID) 

OIMEN 

46 

IF(ISRCH(U  .EQ.  H GOTO  35 

OIMEN 

47 

IDTYP*1 

OIMEN 

48 

CALL  STORE 

OTMEN 

49 

LOC*NIO 

OIMEN 

50 

35  IF(BITGET(IOT0L(3,LOC»  ,13.1»  .NE.  1»  CALL  ERR0R(9) 

OIMEN 

51 

IF  (BITGE  TdOTBL  (3,L0C»  , 1,  It  .NE.  01  GO  TO  130 

OIMEN 

53 

C**  SET  "VARIABLE  DIMENSION-  FLAG 

OIMEN 

53 

IOTBL  ( 3,LOC)*0  ITPUT(  IDTBL  ( 3,L0C)  , 1,131 

OIMEN 

54 

C**  SET  TYPE  ANO  MAKE  SURE  IT  IS  INTEGER 

OIMEN 

55 

CALL  IMPTYP 

OIMEN 

56 

jd 


IF  (BITGET(IOTBL«3,LOC1  .lOtJ)  .NE.  41  C»LL  EPPORCJ) 

OINEN 

57 

IOIHII)«?*»lF*LOC 

OINEN 

56 

14 

IFIMEXTUPTRI  .EQ.  C0MH*1  go  to  15 

OINEN 

59 

IFI»«JPTR-1I  .NE.  RP»RI  GO  TO  110 

OINEN 

60 

LOC*IE 

DIMEN 

61 

C**  STORE  MO.  Of  DIMENSIONS 

OTHEN 

6Z 

IOTBL(3,LOCIsBITPUT(IOTBL  < 3, loci ,1,71 

OIMEN 

63 

IfCI  *GT.  31  GO  TO  110 

OINEN 

64 

Iffl'Z)  3S*30,Z4 

OIMEN 

65 

?4 

IOTBL  (4,L0CUBITPUT<IDTBL  (4,L0CI  f lOIMl  31  ,361 

DTMEN 

66 

STORE  DIMENSION  SI7ES 

OIMEN 

67 

30 

IOTBL  (4,LOCt*BITPUTIIOTBL(4,LOC»  . IOIN(^l  ,161 

OIMEN 

66 

3S 

IOTBL  (3.L0CUSITPUTII0TBL(3,L0CI,  lOINIlt  ,36) 

OIMEN 

69 

IF  (BITGET(IOTBL(3,LOC)  ,16,1)  .NE.  1)  GO  TO  50 

OIMEN 

70 

C»*  VAPIieiE  IN  COMMON,  RESET  COMMON  BLOCK  SIZE 

OIMEN 

71 

C0ML0CsI0TBLI6,L0CI 

OIMEN 

72 

IT  = 1 

OIMEN 

73 

ITPsBITGETI IOTBL ( 3 ,L OC 1 , 1 0 , 3 ) 

OIMEN 

74 

IFUTP  .EQ.  ? .OP.  ITP  .EQ.  31  IT  = Z 

OINEN 

75 

IOTBL  C4,C0ML0CI*I0TBL  C4,C0K.0CI  ♦IT^f  INCR-D 

OIMEN 

76 

SO 

CONTINUE 

OIMEN 

77 

IftNEXnjPTRI  «EQ.  COMMA)  GO  TO  1? 

OIMEN 

76 

IfUPTR  .GT.  N)  RETURN 

OIMEN 

79 

110 

CALL  ERRORC7) 

OINEN 

60 

RETURN 

OIMEN 

61 

IZO 

CALL  ERR0R<14,NXTI0I 

OIMEN 

62 

RETURN 

OIMEN 

63 

END 

OIMEN 

64 

[ 


SUBROUTINE  00 

DO 

2 

COHHON  M13E6)  .O(6  0a).IOTBL(8.600ltINITIOI3(.L*STIO(3t  ,ISRCH(3  1, 

RICH 

2 

• JPTR.N.M, JTTP.L START, N2, IFNCNM, LOGIO. MX TI 0. 10  TYP.NTO.LOC, 

CY5  8A 

80 

2 LTYP,  ITYP.IBLXOT  .MOOE.IERR,  lOES 

RICH 

A 

COHHON/L ABELS/ST *TR*( 2, 200), NLA BEL 

00 

A 

COMMON/OOLOOP/  ISTACXCI.,6  01  ,NST  ACK,  I LOOP,  lOVFLM 

00 

5 

COMMON/BASBLX/IBLOCX  (?50  0)  ,NBL  OCX  ,NB  ,N8R  NCH 

CY58A 

31 

OIMENSION  PARAMI3) 

00 

7 

INTEGER  A,BLANK,C0MMA,EQUALS,0EE,0H,PARAN,ST  ATRA 

00 

8 

INTEGER  BITPUT,BITGET 

00 

9 

OATA  8LANK/1M  /, COMMA/ IH ,/, EQUAL S/1H< / ,0 EE/1  HO /, OH/1  HO/ 

00 

10 

c** 

OO  STATEMENT  PROCESSOR 

00 

11 

IF  INEXT(JPTR)  ,NE.  OEE)  go  to  50 

00 

12 

IF  (NEXT  ( JPTR)  ,NE.  OH)  GO  TO  50 

30 

13 

c»» 

GET  00  TERMINAL 

00 

lA 

CALL  GNLE 

00 

15 

IF (JTYP  ,NE.  5 ) GOTO  50 

00 

16 

c»* 

search  statement  NUMBER  TABLE 

DO 

17 

CALL  STSRCH 

00 

18 

c»» 

SET  FLAGS 

00 

19 

STATRA(2,LOC)  *8ITPUT(STATRA(2,L0C)  ,1,  12) 

00 

20 

ST ATR A (2, LOO  =81  TPUT  (STATRAI  2 , L OC)  , 1,  1 5) 

00 

21 

IF  (lOVFLM  ,EQ.  1 ) GO  TO  2 

00 

22 

c*» 

INCREMENT  00  STACK  COUNTER 

00 

23 

NSTACK=NSTACK*1 

00 

2A 

IFINSTACK  .GT.  50)  GO  TO  1 

DO 

25 

c»» 

STORE  00  terminal  ANO  “CURRENT  LOOP”  IN  00  STACK 

00 

26 

ISTACK  tl,NSTACK) =L0C 

00 

27 

ISTACK(2,NSTACK)*0 

00 

28 

ISTACK) 3, NSTACK) = ILOOP 

00 

29 

RESET  VALUE  OF  CURRENT  LOOP 

00 

30 

ILOOP=  NSTACK 

00 

31 

GO  TO  2 

00 

32 

1 lOVFLN'l 

DO 

33 

MRITE (6,60) 

00 

3A 

60  FORMtT <///5X,50H  00  ST*CK  OVERFLOM  - 00  LOOP  PROCESSING  TERMIN«TEO 

00 

35 

•) 

00 

36 

C»» 

GET  00  INDEX 

00 

37 

2 CALL  GNLE 

00 

38 

IF(JIYP  .NE.  2)  GO  TO  50 

00 

39 

C»» 

GET  SYMBOL  TABLE  LOCATION 

00 

AO 

CALL  search 

00 

A1 

IF(ISRrH(2)  ,E0.  1)  CALL  ERROR  ( 10  ,NXT  I 0) 

00 

A2 

IF(ISRCHd)  .EQ.  1)  GO  TO  5 

00 

A3 

IOTYP-1 

00 

AA 

CALL  STORE 

00 

AS 

LOC»NIO 

00 

A6 

C*» 

CHECK  THAT  INDEX  IS  AN  INTEGER  VARIABLE 

00 

A7 

5 CALL  D*>TYP 

00 

AS 

IF(BITGET(I0r8L(3,L0C)  ,10,3)  ,NE.  A)  CALL  ERROR(AO,NXT  10) 

00 

A9 

IF(BITGET(I0TBL(3,L0C)  ,1,1)  ,EQ.  1)  CALL  ERROR  (1  A,  NXTIO) 

00 

50 

IF(NEXT)JPTr)  .me.  EQUALS)  GO  TO  50 

00 

51 

IF (lOVFLM  .EQ.  1 ) GO  TO  8 

00 

52 

STORE  00  INOEX  IN  BASIC  BLOCK  TABLE 

DO 

53 

NBL0CK*N8L0CX»1 

00 

5A 

IBIOCK  (NBLOCK)  «3000»LOC 

00 

55 

C»» 

STORE  00  INOEX  IN  00  STACK 

00 

56 

\h 


IS TACK I4«NSTACK) «LOC 

00 

57 

9 PARAHC3I=1 

00 

59 

C**  GfT  NCKT  DO  PARAMCTER 

00 

59 

00  30  I:l«3 

00 

60 

CALL  GNLE 

00 

61 

IF  IJTVP  51  GO  TO  10 

00 

62 

C»^  00  PARAHETER  IS  AN  INTEGER  - STORE  VALUE 

00 

63 

PARAHf  II  «N? 

DO 

64 

IF<N?  «L£«  01  CALL  ERR0R(41I 

00 

65 

GO  TO  20 

00 

66 

10  IFfJTVP  .NE.  2}  GO  TO  SO 

00 

67 

C*»  00  PARAMETER  IS  A VARIABLE  - GET  SYMBOL  TABLE  LOCATION 

00 

66 

CALL  search 

00 

69 

IF(ISRCMI2>  .EO.  11  CALL  ERROR f 10 ,NX T 1 01 

00 

70 

IFfISRCHIll  .EQ.  11  GO  TO  IS 

00 

71 

I0TVP«1 

00 

72 

CALL  STORE 

00 

73 

L0C«NI0 

00 

74 

C*»  CHECK  THAT  IT  IS  AN  INTEGER 

00 

75 

15  CALL  IMPTYP 

DO 

76 

IF(BITGET(I0TBLt3«L0CI «10«3I  .NE*  4|  CALL  E RRO R ( 40 , NX T lOI 

00 

77 

IF(eiTGET(Ior0L(3,LOCI  ,l«ll  .EQ.  11  CALL  ERROR  (1 4, NX T 1 01 

00 

76 

STORE  DO  PARAMETER  IN  BASIC  BLOCK  TABLE 

00 

79 

NBLOCKsNBLOCK^l 

00 

60 

IBLOCK  (N6L0CKI s7  0 00«LOC 

00 

61 

C**  STORE  LOOP  IN  SYMBOL  TABLE 

00 

62 

IOTBL(3«LOC)-BITPUT< lOTBL (3«L0CI « IL00P«36I 

00 

63 

PARAMCIIsO 

00 

64 

20  IF<I  «EQ.  31  GO  TO  30 

DO 

95 

IF (I  .EQ.  1)  GO  TO  25 

00 

66 

IF  INEXTf JPTRI  »EQ«  BLANK)  GO  TO  3S 

00 

67 

jptr=jptr-i 

DO 

66 

25  IFINEXTIJPTRI  .NE.  COMMA)  GO  TO  50 

00 

69 

30  CONTINUE  ^ 

00 

90 

IFfNEXTUPTR)  .NE.  BLANK)  60  TO  SO 

00 

91 

C**  CHECK  SIZES  OF  00  PARAMETERS 

00 

92 

35  IFtPARAMd)  .EQ.  0 .OR.  PARAM<2)  .EQ.  01  GO  TO  AO 

DO 

93 

IF|PARAM(2)  .LT«  PARAH(ll)  CALL  ERR0R(41) 

00 

94 

IFfPARAH(3)  .EQ.  0)  GO  TO  40 

00 

95 

IF(fPARAM<2)»PARAM<3)-l)  • GT . <2*»17-2I)  CALL  ERR0R<41) 

00 

96 

C*«  STORE  BRANCH  IN  BASIC  BL  XK  TABLE 

00 

97 

40  NBLOCK«N0LOCXA1 

00 

96 

IBLOCKfNBLOCKi  >990 

00 

99 

NBRNCH«1 

00 

100 

NB*1 

00 

101 

RETURN 

00 

102 

SO  CALL  ERRORC7) 

00 

103 

RETURN 

00 

104 

ENO 

00 

105 

SUBROUTINE  EQUIV 

EOUIV 

2 

common  AI13?6I  tOlSOOl  • I0TBL<  ^*900  > • INITI  0(3>  «L  ASTIOO) 

,ISRCH(3I, 

RICH 

2 

• JPTff,N,M, JTYP^L START, N2, IFHCNM*L0GI0* NX TIO*  TO  TVPtNiO, 

LOG, 

CY56A 

60 

2 LTYP, ITYP,IBLKOT ,M00E*IERR.I0ES 

RICH 

4 

or  MENS  ION  lALPHdll  , IOrH(3l«  rSUBI3> 

EOUIV 

k 

INTEGER  BITPUT.BITGET 

EOUIV 

5 

INTEGER  A,RPAR,C0NMA,80EFST«BL  ANK 

EOUIV 

6 

DATA  lIALPHtn  ,I»l,ll)/lHE»lHQ,lHU,lHI,lHV,lHA,lMt,lHE 

.IHN.IMC, 

EOUIV 

7 

1 IHE/ 

EOUIV 

6 

DATA  LPAR/1HI/,RPAR/IH)/,C0MMA/1H,/,8LANK/1H  / 

EQUIV 

9 

c**  equivalence  statement  processor 

EQUIV 

10 

00  5 

EOUIV 

11 

IE<NEXT<JPTRI  .NE.  IALPH<IM  GO  TO  130 

EOUIV 

12 

5 CONTINUE 

EQUIV 

13 

S IF(NEXTUPTR)  .NE,  LPAR)  GO  TO  130 

EOUIV 

14 

LSTLOC^O 

EOUIV 

IS 

POFFSTsO 

EOUIV 

16 

J=fl 

EOUIV 

17 

1?0  J=J41 

EOUIV 

16 

C**  GET  NEXT  VARIABLE  ANO  STORE  IN  SYMBOL  TABLE 

EOUIV 

19 

CALL  GNLE 

EQUIV 

20 

ILOC*l 

EQUIV 

21 

IF  IJTYP  ,NE.  GO  TO  130 

EOUIV 

22 

CALL  SEARCH 

EOUIV 

23 

IFCISRCH^^)  .EQ.  11  CALL  E RROR  UO  ♦NX  T lOl 

EQUIV 

24 

IF(ISRCH(1)  .EQ.  1)  GO  TO  9 

EOUIV 

25 

I0TVP=1 

EOUIV 

26 

CALL  STORE 

EQUIV 

27 

LOC-NIO 

EOUIV 

26 

9 CALL  If«»TYP 

EOUIV 

29 

If  ferTGCT(rOTBL(3,LOC».l^,l»  .EO.  1»  C4LI  ERP0SI?0,NltT  10) 

EOUIV 

30 

iFJMEXTf JPTR)  ,NE.  LPARI  GO  TO  SO 

EQUIV 

31 

rF(eiTGET(ioreL(3,Loc» «iti»  .ne.  n co  to  iso 

EOUIV 

32 

C*»  SUBSCRIPTED  VARIABLE 

EOUIV 

33 

NOIM^BITGETflOTBL ( 3* LOCI , 7,6) 

EOUIV 

34 

00  10  IslfNOIH 

EQUIV 

3S 

GET  NEXT  SUBSCRIPT 

EQUIV 

36 

CALL  GNLE 

EOUIV 

37 

IFCJTYP  .NE.  S)  GO  TO  130 

EOUIV 

36 

lOIHf II*N3 

EOUIV 

39 

IFtNZ  .LE,  01  CALL  ERRORIS) 

EOUIV 

40 

lMR0*34l/2 

EOUIV 

41 

iPOSsia*Mooa»2Mi8 

EQUIV 

42 

€••  GET  CORRESPONDING  OIMENSION  FROM  SYMBOL  TABLE 

EOUIV 

43 

ISUBdIsBITGET  CIOTBLIIWROfLOCI  * IPOS,  161 

EOUIV 

44 

IF<N2  ,GT,  ISUBdll  CALL  ERRORflO) 

EOUIV 

45 

IF  CNEXTf  JPTRI  ,EQ«  COHMAI  GO  TO  10 

EOUIV 

46 

IF(AfJPTR*ll  «NE«  RPAR)  GO  TO  ISO 

EOUIV 

47 

GO  TO  IS 

EOUIV 

46 

10  CONTINUE 

EQUIV 

49 

GO  TO  1%0 

EOUIV 

SO 

C**  CALCULATE  DISTANCE  OF  SUBSCRIPT  FROM  BEGINNING  OF  ARRAY 

EOUIV 

SI 

IS  NOTH* I 

EOUIV 

52 

ILOCstOINdl 

EQUIV 

S3 

IF(N0IM  .EQ*  11  GO  TO  ?S 

EOUIV 

54 

ILOC*ILOCACIOINdl-ll*ISueiH 

EOUIV 

SS 

IFINOtM  ,EQ*  21  GO  TO  2S 

EOUIV 

56 

c* 


c* 

c» 

c» 

c* 


c»» 


IL0C>IL0C*II0IH(3l-ll*ISUBIlt*ISUei3t 
ZS  IT«BITGET(tOTBL(3, LOCItlO.il 

• ADJUST  DISTANCE  IE  DOUBLE  PREC.  OR  COMPLEX 

IEIIT  .EQ.  Z .or.  it  .EQ.  31  ILOC*Z>ILX 

* CALCULATE  OFFSET  OF  VARIABLE  FROM  BEGINNING  OF  EQUIVALENCE  LINK 

IOFFST.I-ILX-BOFFST 
GO  TO  AS 

30  IFIBITGETIIOTBLII, LOCI  .1.11  .NE.  01  CALL  ERROR  II  A,  NXTIOl 

non-subscripteo  variable,  set  offset.base  offset 

IOFFST*BOFFST 

JPTR«JPTR-1 

AS  IFIBITGETIIOTBLII, LOCI  ,17,11  .EQ.  II  GO  TO  S7 
VARIABLE  NOT  PREVIOUSLY  EQUI VALE NCEO, SET  "EQUIVALENCEO"  FLAG 
IOTBLI3,LOCI<BITPUTIIOTBLI3,LOCI ,1,171 
BRANCH  IF  NO  VARIABLES  YET  IN  EQUIVALENCE  LINK 
IFILSTLOC  ,EQ.  01  GO  TO  SO 

SET  POINTER  FROM  PREVIOUS  VARIABLE  TO  PRESENT  VARIABLE 
IDTBLI7,LSTLOCI*LOC 
GO  To  55 

SET  BEGINNING  OF  EQUIVALENCE  LINK 
so  IFSTLC*L0C 

STORE  offset  of  VARIABLE  IN  SYMBOL  TABLE 
55  I0TBLI8,L0CI*I0FFST 

RESET  -last  VARIABLE  IN  LINK”  TO  PRESENT  VARIABLE 
LSTLOC*LOC 

IF  FIRST  VARIABLE  IN  LINK,  PROCESSING  DONE 
IFIJ  .NE.  II  GO  TO  too 
GO  TO  98 

VARIABLE  MAS  BEEN  PREVIOUSLY  EOUIVALENCEO 

57  LOC3  = LOC 

58  LOC3cIOTBLI7,LOC3I 
IFILOCl  .EQ.  01  GO  TO  59 
IFILOC3  .EQ.  LOCI  GO  TO  60 
GO  TO  58 

59  JLOC«ILOC*IOTBLI8,LOCI 

IFIJLOC  .NE.  IDISI  CALL  ERRORI  ZO  . lOTBL  II  ,LOC  1 1 
GO  TO  too 

RE-OPEN  link  and  set  FIRST  LXATION  TO  PRESENT  VARIABLE 

60  IFILSTLOC  .NE.  01  GO  TO  63 
IFSTLC*LOC 

GO  TO  65 

63  lOTBL  (7,LSTL0CI»L0C 
65  LOCZ»LOC 

THIS  LOOP  FINOS  THE  END  OF  THE  LINK 
70  NKTLOC«IOTBLI7,LOCZI 

IFINXTLOC  .EQ.  LOCI  GO  TO  75 

LOCZ«N*TLOC 

GO  TO  70 

LINK  IS  RE-OPENEO  MERE 
75  IDTBL  I7,LOCZI*0 

RESET  LAST  VARIABLE  IN  LINK  TO  PRESENT  VARIABLE 
LSTLOC»LOCZ 

CALCULATE  OFFSET  DIFFERENCE  BETWEEN  PRESENT  AND  ao  OFFSETS 
IOFFOF»IOFFST-IOTBL  1 8, LOCI 
IFIIOFFOFI  80,98,90 

NEW  offset  is  less  than  old  offset 

ALL  OFFSETS  FROM  HERE  ON  IN  EQUIVALENCE  LINK  MUST  BE  CHANGED 


EOUIV 

57 

CQUIV 

58 

EOUIV 

59 

EOUIV 

61 

EOUIV 

61 

EOUIV 

62 

EOUIV 

63 

EOUIV 

64 

EOUIV 

69 

EOUIV 

66 

EOUIV 

67 

EOUIV 

66 

EOUIV 

69 

EOUIV 

79 

EOUIV 

71 

EOUIV 

72 

EOUIV 

73 

EOUIV 

74 

EOUIV 

79 

EOUIV 

76 

EOUIV 

77 

EOUIV 

76 

EOUIV 

79 

EOUIV 

60 

EOUIV 

61 

EOUIV 

62 

EOUIV 

63 

EOUIV 

64 

EOUIV 

69 

EOUIV 

66 

EOUIV 

67 

EOUIV 

66 

EOUIV 

69 

EOUIV 

90 

EOUIV 

91 

EOUIV 

92 

EOUIV 

93 

EOUIV 

94 

EOUIV 

95 

EOU  IV 

96 

EOUIV 

97 

EOUIV 

96 

EOUIV 

99 

EOUIV 

100 

EOUIV 

101 

EOUIV 

102 

EOUIV 

103 

EOUIV 

104 

EOUIV 

105 

EOUIV 

106 

EOUIV 

107 

EOUIV 

106 

EOUIV 

109 

EOUIV 

110 

EOUIV 

111 

EOUIV 

112 

EOUIV 

113 

SQ  L0C2*L0C 

ECU  IV 

114 

eS  IOT0H8,LOC2I  «IOT0U8,LOC?lfIOFrOF 

EOUIV 

115 

LOC2*IOT0L  I7*L0C?» 

EOUIV 

116 

IFaOC2  .EO.  •)  GO  TO  98 

EOUIV 

117 

GO  TO  85 

EOUIV 

118 

NE«  OFFSET  GREATER  THAN  OtO  OFFSET 

EOUIV 

119 

C**  OFFSETS  OF  PREVIOUS  VARIABLES  IM  tINR  HUST  0E  CMARCEO 

EOUIV 

120 

90  LOC2»IFSTLC 

EOUIV 

121 

95  IFCtOC2  .EQ.  LOCI  GO  TO  97 

EOUIV 

122 

lOTBl  I8,L0C?I  sIOTBL  (8f  L0C2»-I0FF0F 

EOUIV 

123 

LOC2«IOT0L l7tLOC?) 

EOUIV 

124 

GO  TO  95 

EOUIV 

125 

C**  RESET  BASE  OFFSET 

EOUIV 

126 

97  0OFFST»9OFFST-IOFFOF 

EOUIV 

127 

98  IOIS>UOC«IOT0L(8«LOCI 

EOUIV 

128 

100  If CNEXTf JPTR>  «EO«  COMMA)  CO  TO  1?0 

EOUIV 

129 

IFfAfJPTR*!)  .ME*  RPAR)  GO  TO  130 

EOUIV 

131 

IF(J  .EQ.  1)  GO  TO  130 

EOUIV 

131 

€•*  CLOSE  equivalence  LINK 

EOUIV 

132 

IOT0LI7,LSTLOCI*IFSTLC 

EOUIV 

133 

JK«0 

EOUIV 

134 

LOC3SIFSTLC 

EOUIV 

135 

C^*  TRAVERSE  EQUIVALENCE  LINK 

EOUIV 

136 

I«0 

EOUIV 

137 

110  I«I^1 

EOUIV 

138 

L0C3*I0TBL<7,L0C3I 

EOUIV 

139 

IF(0ITGET(IOt.BLf3»LOC3),16a)  •EQ.  01  GO  TO  105 

EOUIV 

140 

C**  variable  IN  COMMON.  INCREMENT  COUNTER 

EOUIV 

141 

JK«JKtl 

EOUIV 

142 

C**  IF  TOO  MANY  VARIABLES  IN  COMMON,  ISSUE  DIAGNOSTIC 

EOUIV 

143 

IFCJK  .GT.  1)  CALL  ERROR  f 21,  I0T6L  (1 , LOC3  ) , 10  T0  L 11 , LOC 1 > > 

EOUIV 

144 

LOC1*LOC3 

EOUIV 

145 

LOC*LOC3 

EOU  IV 

146 

C**  CHECK  TO  SEE  IF  COMMON  NAS  EKTENOEO 

EOUIV 

147 

CALL  COMEXT 

EOUIV 

148 

105  IFILOC3  .NE.  IFSTlO  GO  TO  110 

EOUIV 

149 

IF INEXr f JPTR)  «EO«  BLANK)  RETURN 

EOUIV 

150 

IFUfJPTR-l)  «EQ.  COMMAI  GO  TO  8 

EOUIV 

151 

130  CALL  ERROR(7) 

EOUIV 

152 

RETURN 

EOUIV 

153 

140  CALL  ERR0Rfl9) 

EOUIV 

154 

RETURN 

EOUIV 

155 

150  CALL  ERROR(13,NXTtO) 

EOUIV 

156 

RETURN 

EOUIV 

157 

END 

EOUIV 

158 

■'.() 


SUBRUUTINt  E»BOR  t lEBOOO.  INUM, I NUB?1 

f (R 

2 

COMHON  All326).0(500l«IOTeL(9.500l«lNlTin(3l,L*STIO(n.  IS»Ch(S  )• 

RICH 

2 

• JPTP, N,M, JT7P,LSTAPT*N2, IFNCNH,lOGIO t N*  T!0, 10  Tt P , Nl 0 • L OC , 

CT5  8A 

80 

2 LTYP,  ITYP,  IBLKDT.MOOE  , IEPP.  I0E«‘ 

RICH 

4 

COHM ON/f LOM/IFL 

E 

4 

ERPOP  MESSiGE  GENERATOP 

EPROP 

5 

MRITE (6,1) 

f VR  CR 

6 

£DROR 

8 

CO  TO  (5, 1S,^5 ,35,45,55,65,75.  S5,  R?,  10  5,  116,  t?6.  1 TS.  IbS. 

Ff'R  CR 

9 

A 175*1 85, 195*2  0 5,  215,225,  2 35, 24 5, ?55, 2 6 5,  ?7 ?8  5, ?9S,  30  5,  315,  375, 

E PP  OR 

10 

• 3 35,  345,355,  3 65 , 375 , 3 95 , 395 , 4 05 , 4 15 , 4 25  ,4 35 , 4 45 , 4 55 , 4 65 , 4 75 , 4 85  , 

ERROR 

11 

• 4 95,505,515,  525,535,545,555,565,575,5  85  ,595  , 6 05 , 6 15 , 6 25 , 6 ^5 , b45 , 

E RR  OR 

12 

S 655,665,675,  6 85 , 695 , 7 05 , 7 15 , 7 25 , 7 35 , 745 , 755 , 7 65 , 7 75 , 7 85 , 7 95 , 8 05 , 

ERR  CR 

13 

1 8 15,  8 25, 6 35,  8 45, 855, 5 65,8  75, 8 *5, 595,905  . 9 15, 5 75,5  35,545)  .TERROR 

CY^SA 

55 

5 

MPITE(6,  10) 

ERR  CR 

15 

10 

F0RH«T(6X,264  THIS  ST8TEHENT  IS  ILLEG81.) 

ERR  CR 

16 

GO  TO  1000 

E PROP 

17 

15 

NPITEU,  20) 

errcr 

19 

?0 

FOPH8T  (6X,  31H  THIS  ST8TEHENT  IS  OUT  OF  ORDER) 

ERR  CR 

19 

GO  TO  1000 

ERR  (R 

20 

25 

HPTTE(6,  30) 

ERR  CR 

21 

30 

FORMAT I6X,39H  VALUE  OF  INTEGER  CONSTANT  IS  TOO  LAPGF) 

ERR  OR 

22 

GO  TO  1000 

ERR  CR 

23 

35 

MRITE<6,  40) 

ERROR 

24 

HO 

FORMAT  I6X,28H  TOO  MANY  CONTINUATION  CAPOS) 

ERROR 

25 

GO  TO  1000 

ERR  CP 

26 

45 

MRITE(6,  50) 

ERR  (R 

27 

50 

FORMAT C6X,30M  HOLLERITH  STRING  IS  TOO  LARGE) 

ERR  OR 

28 

GO  TO  1000 

ERROR 

29 

55 

HRITE(6,  60) 

ERROR 

30 

60 

FORMAT <6X,26H  VARIABLE  NAME  IS  TOO  LONG) 

ERROR 

31 

GO  TO  1000 

ERROR 

32 

65 

WRITEC6,  70) 

ERR  (R 

33 

70 

FORMAT(6X,31H  SYNTAX  ERROR  IN  THIS  STATE>€NT) 

ERR  CR 

34 

IFCITYP  ,LE.  18  .AND,  IFL  ,CT.  0)  IFL*-1 

ERR  CR 

35 

GO  TO  1000 

ERR  OR 

36 

75 

HRITE(6,  80) 

ERR  CR 

37 

so 

FORMAT  (6X,46H  ARRAY  OIMENSION  IS  OUTSIDE  OF  ALLOMARLE  RANGE) 

ERROR 

38 

GO  TO  1000 

ERR  OR 

39 

95 

MRITE(6,  90) 

ERROR 

40 

90 

FORMAT  (6X,45H  ILLEGAL  VARIABLE  DIMENSION  IN  THIS  STATEMENT) 

ERROR 

41 

GO  TO  1000 

ERR  CR 

42 

95 

HRITE(6,100)  INUM 

ERR  C9 

43 

ISO 

FORN«T(6X,33H  THE  function  OR  SUBROUTINE  NONE  ,*6,18H  IS  USED  ILLE 

ERR  CR 

44 

•GALLY) 

ERROR 

45 

GO  TO  1000 

ERRCR 

46 

105 

MRITE(6,110)  INUN 

ERROR 

47 

110 

F0RN*T(6X,14H  THE  ¥»RI*BlE  ,»6,32H  H»S  BEEN  PREVIOUSLY  OIMENSIONEO 

ERROR 

48 

•) 

ERR  CR 

49 

GO  TO  1000 

ERR  CR 

50 

115 

MRITE(6.120)  INUH 

ERR  CR 

51 

120 

FORN«T(6X,14H  THE  VARIABLE  ,A6,26H  HAS  BEEN  PREVIOUSLY  TYPED) 

ERR  CR 

52 

GO  TO  1000 

ERR  CR 

53 

MRITE(6,130)  INUM 

ERR  CR 

54 

130 

FORMAT (6X,14H  THE  VARIABLE  ,A6*38H  IS  ILLEGALLY  FOLLOWED  BY  A LEFT 

ERROR 

55 

• PAREN) 

ERR  CR 

56 

GO  TO  1000 

ERR  CR 

57 

135 

WRITE(6*140»  INUH 

ERROR 

58 

140 

FORHAT  (6X«26H  TH£  0IHENSI0»€0  VARIABie  tA6*ltM  t5  USED  ILtCGALLVI 

ERR  CR 

59 

GO  TO  1000 

ERR  CR 

60 

145 

WPITEI6»150»  INUM 

ERROR 

61 

150 

FORHAT <6X,18N  STATEMENT  NUMBER  .I5»15H  IS  NOT  OEFIMEOI 

ERR  OR 

6? 

IFUFL  .GT.  0)  IFL=-1 

ERROR 

63 

GO  TO  1000 

ERR  CR 

64 

155 

MRITE(6*160I  INUM 

ERR  CR 

65 

160 

fOPMAM6X,16H  STATEMENT  NUMBER  #I5,16H  IS  NOT  REFERENCEO) 

ERR  CR 

66 

GO  TO  1000 

ERROR 

67 

165 

WRITEI6»170)  INUM 

ERR  CR 

68 

•-3 

FORMAT <6X,16H  ILLEGAL  VARIABLE  «A6tl0H  INCOHNONl 

ERROR 

69 

GO  TO  1000 

ERRCR 

70 

17*= 

MRITE (6«160) 

ERR  CR 

71 

l«0 

FORMAT (6X*43M  VALUE  Of  ARRAY  SUBSCRIPT  EXCEEDS  OIMENSIONl 

ERR  CR 

72 

GO  TO  1000 

ERR  CR 

73 

165 

WRITE (6, 1901 

ERRCR 

74 

190 

F0RMATI6X,25M  ERROR  IN  ARRAY  SUBSCRIPT) 

ERR  CR 

75 

GO  TO  1000 

ERRCR 

76 

195 

HRITE(6»200)  INUM 

ERR  OR 

77 

^0  0 

FORHAT<6X,16M  ILLEGAL  VARIABLE  tA6»16H  1$  EQUI VALENCEO ) 

ERRCR 

78 

GO  TO  1000 

ERRCR 

79 

205 

WRITE (6,210)  INUM, INUM? 

ERRCR 

80 

2t0 

FORMAT <6X,22M  THE  COMMON  VARIABLES  ,A6,5M  ANO  ,A6,17H  ARE 

EQUI VALE 

ERROR 

81 

•NCfOl 

ERRCR 

82 

GO  TO  1000 

ERROR 

83 

215 

WRITE (6,220) 

ERRCR 

84 

22  0 

FORMAT (6X,19H  ILLEGAL  I/O  OEVICEI 

ERROR 

85 

GO  TO  1000 

ERROR 

86 

225 

WRITE(6,230) 

ERR  CR 

87 

230 

FORMAT (6X,37H  ILLEGAL  CHARACTER  IN  THIS  EXPRESSION) 

ERROR 

86 

GO  TO  1000 

ERR  CR 

89 

235 

WRITEI6,240)  INUM 

ERR  OR 

90 

240 

FORMAT (6X,25H  ILLEGAL  SUBROUTINE  NAME  ,A6) 

ERROR 

91 

GO  TO  1400 

ERROR 

92 

245 

WRITE (6,250) 

ERR  CR 

93 

25  0 

rOffHAT  (6X,50H  SUBROUTINE  TABLE  OVERELON  - PROCESSING  TERHINATEDI 

ERROR 

94 

GO  TO  1000 

EPR  CR 

95 

255 

WRITE(6,260)  INUM 

ERRCR 

96 

26  0 

FORMAT (6X,77H  INCORRECT  NUMBER  OF  ARGUMENTS  IN  CALLING  SEQUENCE  OF 

ERROR 

97 

S FUNCTION  OR  SUBROUTINE  ,A6) 

ERROR 

98 

GO  TO  1000 

ERR  CR 

99 

265 

WRITE (6,270) 

ERR  CR 

100 

27  0 

FORMAT (6X,19H  ILLEGAL  ASSIGNMENT) 

ERROR 

101 

GO  TO  1000 

ERR  CR 

102 

275 

WRITE(6,  280)  INUM 

ERROR 

103 

260 

FORHAT  l6Xil4H  THE  VARIABLE  tA6<<tZH  APPEARS  IN  A OATA  STATEMENT  ANO 

ERR  CR 

104 

• IN  COMMON) 

ERROR 

105 

GO  TO  1000 

ERROR 

106 

285 

MRITE(6,290)  INUM 

ERROR 

107 

290 

FORMAT  (6X,14H  THE  VARIABLE  ,A6,44M  HAS  PREVIOUSLY  APPEARED 

IN  A DA 

ERR  CR 

toa 

•TA  STATEMENT) 

ERROR 

109 

GO  TO  tOOO 

ERR  CR 

110 

295 

WRITE(6,30Q)  INUM 

ERR  CR 

ill 

30  0 

format (6X«22H  THE  FORMAL  PARAMETER  ,A6,3lH  APPEARS  IN  THIS 

DATA  ST 

ERROR 

112 

•ATEMENT) 

ERR  CR 

113 

GO  TO  1000 

ERR  OR 

114 

30S 

WRITE<6,310I 

ERROR 

115 

310 

FORMAT  C6X,24H 

LIST  SIZES  DO  NOT  MATCH) 

ERR  CR 

116 

GO  TO  1000 

ERR  CR 

117 

315 

NRITE  <6«  3201 

ERROR 

lie 

32  0 

F0RMATI6X,24H 

ILLEGAL  STATEMENT  LABEL) 

ERROR 

119 

IFIIFL  •GT.  0) 

IFL*-1 

ERROR 

120 

CO  TO  1000 

ERROR 

121 

1?5 

WRITF(6«330> 

ERROR 

122 

330 

FORMAT  <6X,26H 

DUPLICATE  STATEMENT  LABEL) 

ERROR 

123 

IFIIFL  .GT.  01 

ifl»-i 

ERROR 

124 

GO  TO  1000 

ERR  CR 

125 

335 

MRITF 16.340) 

ERROR 

126 

34  0 

FORMAT  16X.34H 

this  STATEMENT  CAN  NOT  BE  REACKID) 

ERROR 

127 

GO  TO  1000 

ERR  CR 

129 

345 

MRITFIG, 350) 

ERROR 

129 

35  0 

FORMAT  I6X.31H 

00  LOOPS  ARE  IMPROPERLY  )CSTEO) 

ERR  CR 

130 

GO  TO  1000 

ERR  OR 

131 

355 

MRITEI6.360) 

ERROR 

132 

360 

FORMAT  16  X, 32H 

FORMAT  statement  IS  NOT  LABELED) 

ERROR 

133 

GO  TO  1000 

ERROR 

134 

365 

WRITF 16. 3701 

ERR  OR 

135 

3T0 

FORMAT  I6X  ,2J4 

illegal  00  TERMINAL) 

ERR  CR 

136 

CO  TO  1000 

ERR  CR 

137 

375 

MRITE (6,390) 

ERR  CR 

139 

390 

FORMAT  I6X.37H 

LAST  EXECUTABLE  STATEMENT  IS  ILLEGAL) 

ERR  CR 

139 

IFIIFL  .GT,  0) 

ifl=-i 

ERROR 

140 

GO  TO  1000 

ERR  OR 

141 

3B5 

WRITEI6.390)  INUM 

ERR  CR 

142 

39  0 

FORMAT (6X.24H 

THE  V«RI«BLE  REFERENCE  IS  NOT  AN  INTEOERI 

ERR  CR 

143 

GO  TO  1000 

ERR  CR 

144 

395 

HRITE(6,400)  INUM 

ERROR 

145 

40  0 

FORMAT  I6X.27H 

THE  00  parameter  OP  INDEX  .A6.18H  IS  NOT  AN  INTEGER) 

ERR  CR 

146 

GO  TO  1000 

ERROR 

147 

405 

WRITE (6.410) 

ERROR 

149 

410 

FORMAT (6X.52M 

VALUE  OF  DO  PARAKETER  IS  OUTSIDE  OF  ALLOWABLE  RANGE) 

ERROR 

149 

GO  TO  1000 

ERR  CR 

150 

415 

WRITE (6.420) 

ERROR 

151 

4?0 

FORMAT (6X,32H 

COMPLEX  EXPRESSIONS  ARE  ILLEGAL) 

ERR  CR 

152 

GO  TO  1000 

ERROR 

153 

42  5 

WRITE(6,430) 

ERROR 

154 

430 

FORMAT (6X.24H 

illegal  VARIABLE  FORMAT) 

ERR  CR 

155 

GO  TO  1000 

ERR  CR 

156 

435 

WRITE (6.4401 

ERROR 

157 

44  0 

FORMAT (6X.39M 

THIS  STATEMENT  SHOULD  HAVE  AN  I/O  LIST) 

ERROR 

159 

GO  TO  1000 

ERROR 

159 

44  5 

WRITE(6.450) 

ERROR 

160 

450 

FORMAT (6X.50M 

STATEMENT  FOLLOWING  LOGICAL  EXPRESSION  IS  ILLEGAL) 

ERROR 

161 

GO  TO  1000 

ERROR 

162 

455 

WRire<6.460) 

ERR  OR 

163 

460 

FORMAT (6X.44H 

REAL  NUMBER  LIES  OUTSIDE  OF  ALLOWABLE  RANGF) 

ERR  CR 

164 

GO  TO  1000 

ERROR 

165 

465 

WRITE (6.470 ) 

ERROR 

166 

470 

FORMAT (6X.429 

THIS  EQUIVALENCE  STATEMENT  EXTENDS  COMMON) 

ERR  OR 

167 

GO  TO  1000 

ERROR 

168 

475 

WRITE (6.490) 

ERR  CR 

169 

490 

FORMAT  (6X.40H 

illegal  variable  in  common  BLOrx  SFSCOM) 

ERR  CR 

1 70 

GO  TO  1000 

ERROR 

171 

48S 

MRITE(6t490)  INUH 

ERR  CR 

172 

490 

FORMAT C6Vtl2H  SUBPROGRAM  ,A6»19H  HAS  INCORRECT  TYPEI 

ERR  CR 

173 

GO  TO  1000 

ERROR 

174 

495 

MRITEf6«500l  INUM 

ERR  CR 

175 

509 

FORMAT  l6Xt23H  WARNING  > ARGUMENT  NO.,13«34H  MAY  HAVE  INCORRECT  DIM 

ERR  CR 

176 

•ENSIONALITY) 

ERR  CR 

177 

GO  TO  1000 

ERROR 

178 

505 

HRITEI6.S10)  INUH 

ERR  CR 

179 

510 

FORMAT(6K,13H  ARGUMENT  NO.*I3tl9H  MAS  INCORRECT  TYPE) 

EPR  CR 

160 

GO  TO  1000 

ERR  CR 

181 

515 

MRITE(6«520) 

ERRCR 

182 

5?0 

FORMAT <6Y,49M  MARNING  - THIS  MODULE  IS  MOT  IN  THE  SESCOMP  LIST) 

ERRCR 

183 

GO  TO  1000 

ERR  CR 

184 

525 

WRITE16.530I  INUM 

ERRCR 

185 

530 

FORMAT (6Y,14H  THE  VARIABLE  ,A6,29H  PREVIOUSLY  APPEARS  IN  COMMON) 

ERROR 

186 

GO  TO  1000 

ERRCR 

187 

535 

HRITEI6t540)  INUM 

ERROR 

188 

54  0 

FORMAT  I6X»13H  ARGUMENT  NO..I3«llH  IS  INVALID) 

ERROR 

189 

GO  TO  1000 

ERR  CR 

190 

545 

WRITE(6*550)  INUM 

ERROR 

191 

55  0 

FORMAT  (6X«13H  ARGUMENT  N0«,I3«?9H  IS  OESIGNATEO  LOGICAL  OUTPUT) 

ERR  OR 

192 

GO  TO  1000 

ERR  OR 

193 

555 

MRITE(6«560)  INUM 

ERROR 

194 

560 

FORMAT (6X,29H  ILLEGAL  COMMON  BLOCK  NAME  • ,A6) 

ERROR 

195 

GO  TO  1000 

ERROR 

196 

565 

MRITEI6,570)  INUM 

ERROR 

197 

570 

FORMAT (6X,41H  WARNING  - VARIABLE  TYPE  IN  COMMON  BLOCK  «A6,41H  DOES 

ERROR 

196 

S NOT  AGREE  WITH  INTERFACE  DEFINITION) 

ERRCR 

199 

GO  TO  tOOO 

ERROR 

200 

575 

WRITE(6«580)  INUM 

ERROR 

201 

589 

FORMAT (6X«14H  COMMON  BLOCK  .AGtlBH  HAS  INCORRECT  SI7E) 

ERR  CR 

202 

GO  TO  1000 

ERR  CR 

203 

585 

WRITE(6«590) 

ERRCR 

204 

590 

FORH«T  (6X.5SH  EXTERNAL  REFERENCE  TABLE  OVERFLON  - PROCESSING  TERMI 

ERR  CR 

205 

SNATEO) 

ERRCR 

206 

GO  TO  1000 

ERROR 

207 

595 

WRITE (6«600) 

ERR  CR 

208 

60  0 

FORMAT  C6X,52H  COMMON  BLOCK  TABLE  OVERFLOW  - PRatSSING  TERMINATED) 

ERR  CR 

209 

GO  TO  1000 

ERR  CR 

210 

60  5 

WRlTE<6*610t  INUM 

ERROR 

211 

610 

FORMAT t6X*29H  ILLEGAL  COMMON  BLOCK  NAME  - ,A6) 

ERR  CR 

212 

GO  TO  1000 

ERROR 

213 

615 

WRITE<6»62Q)  INUM 

ERRCR 

214 

620 

FORMAT  I6X,14H  COMMON  BLOCK  ,A6»27H  IS  MOT  IN  T )€  SESCOMP  LIST) 

ERRCR 

215 

GO  TO  1000 

ERR  CR 

216 

675 

WRITEI6.630)  INUM 

ERR  OR 

217 

630 

format (6Xt25H  CATEGORY  2 COMMON  BLOCK  ,A6t?3H  IS  NOT  GROUPED  BY 

TY 

ERROR 

218 

SPEt 

ERR  CR 

219 

GO  TO  1000 

ERR  CR 

220 

635 

WRITE (6« 640  I INUH,rNUH2 

ERROR 

221 

64  0 

FORMAT  <6X«3SH  DOUBLE  PRECISION  OR  COMPLEX  VARIABLE  ,A6,56H  DOES 

NO 

ERR  CR 

222 

fT  BEGIN  ON  AN  EVEN  LOCATION  WITHIN  COMMON  BLOCK  ,A6) 

ERR  CR 

223 

GO  TO  1000 

ERR  CR 

224 

645 

WRITEI6,65Q)  INUM 

ERROR 

225 

65  0 

FORMAT  (6X,26H  VARIABLE  IN  COMMON  BLOCK  *A6*16H  IS  OUT  OF  ORDER) 

ERR  CR 

226 

GO  TO  1000 

ERRCR 

227 

6SS  MRITE(6,660) 

ERRCR 

228 

660  F09HAT (6V.56H  THE 

COMMON  BLOCK  SESCOM  DOES  NOT  APPEAR  IN  THIS  PROG 

ERROR 

229 

SRAHI 

ERR  CR 

230 

GO  TO  1000 

ERR  OR 

231 

66S  WPXTEI6«670>  X NUH 

ERROR 

232 

670  FORMAT (6X,16H  THE 

00  INDEX  ,A6,13H  IS  REOEFIICOI 

ERROR 

233 

RETURN 

ERROR 

236 

679  HRITE(6,680)  INUH 

ERROR 

2 35 

660  FORMAT (6X,^4H  THE 

VARIABLE  DIMENSION  ,AS.13H  IS  REOEFINEOI 

ERR  CR 

2 36 

RETURN 

ERR  OR 

237 

689  HRITE(6»690)  INUM 

ERROR 

238 

690  FORMAT  CSX, 23H  THE 

ASSIGNED  VARIABLE  ,AS,26H  IS  ILLEGALLY  REFERENCE 

ERROR 

239 

SOI 

ERROR 

260 

RETURN 

ERRCR 

261 

699  MRITEC6,700I  tNUM 

ERR  CR 

262 

700  F0RMATC6X,14H  THE 

VARIABLE  ,A6,30H  IS  REFERENCED  BUT  NOT  DEFINED) 

ERR  CR 

263 

RETURN 

ERROR 

266 

705  MRITE(6f7l0)  iNUH 

ERR  CR 

265 

710  FORMAT C6X,16H  THE 

VARIABLE  •AS.45H  IS  REFERENCED  ILLEGALLY  BY  AN  A 

ERROR 

266 

SSSIGNEO  GO  TOI 

ERROR 

267 

RETURN 

ERROR 

268 

715  MRITEC6,720)  INUM 

ERROR 

269 

720  FORMAT  I6X,18H  THE 

DO  parameter  ,AS,13H  IS  REDEFINED) 

ERR  CR 

250 

RETURN 

ERR  CR 

2 51 

725  MRITEC6,730I 

ERRCR 

252 

730  fORMOT  (6X.H9H  THIS  HOOULE  CONTAINS  NO  CATEGORY  ? COHNON  BLOCKSI 

ERR  CR 

253 

GO  TO  1000 

ERRCR 

256 

735  HRITEcS, 7^*31  XNUM 

ERROR 

255 

760  format  CSX, 26H  THE 

ANSI  FUNCTION  NAME  ,A6,?7H  IS  MISUSED  IM  THIS  PR 

ERR  CR 

256 

SOGRAMI 

ERROR 

257 

GO  TO  1000 

ERROR 

258 

769  NRITE(6,790)  INUM 

ERR  OR 

259 

750  FORMAT  CSX, 16H  THE 

VARIABLE  ,A6,60M  APPEARS  IN  A CATEGORY  ? OR  3 CO 

ERROR 

260 

SMMON  BLOCX  eUT  IS 

NEVER  USED) 

ERR  CR 

261 

GO  TO  1000 

ERROR 

262 

759  NRITEC6,760) 

ERR  CR 

263 

760  FORMAT  (6X,75H  ARRAY  SUBSCRIPT  OR  IMPLIED  DO  PARAMETER  MAY  LIE  OUTS 

ERROR 

266 

SIDE  OF  allowable 

RANGE  I 

ERR  OR 

265 

GO  TO  1000 

ERROR 

266 

765  MRITE«6,7701  INUM 

,INUM2 

ERROR 

267 

770  FORMAT (6X,??M  MIXED  MODE  COMBINING  .A6.6H  WITH  ,A6) 

ERROR 

268 

GO  TO  1000 

ERROR 

269 

775  WRlTEf6,780l  INUM 

ERROR 

270 

780  FORMAT«6X,I3H  INCORRECT  EXPONENT  AT  CHAR.  NO,  ,I3t 

ERR  CR 

271 

GO  TO  1000 

ERROR 

272 

765  HRITEC6,790I  INUM 

ERROR 

273 

790  FORMAT  CSX, 67H  VAR 

-CONST  CONFUSION  IN  SUBSCRIPT  AT  CHAR.  NO,  ,131 

ERR  CR 

276 

GO  TO  1000 

ERROR 

279 

799  MRITEIS,800)  INUM 

,INUM2 

ERROR 

276 

800  FORMAT  I6X, MOM  SUBSCRIPT  CONSTANT  OR  VARIABLE  OF  TYPE  ,A6,16M  AT  CM 

ERROR 

277 

tAR.  NO.  .131 

ERROR 

278 

GO  TO  1000 

ERROR 

279 

805  NRITE(6,810)  INUM 

ERROR 

280 

810  FORMAT (6X.57M  TOO 

MANY  SUBSCRIPTS  FOR  THIS  VARIABLE  AT  CHAR.  NO.  , 

ERROR 

281 

*131 

ERROR 

282 

GO  TO  1000 

ERROR 

283 

815  MRITEI6.870)  INUH 

ERR  CR 

286 

i 

I 


ft 


8?0 

FOPHfiT (6X,51M  TOO  FEW  SUBSCRIPTS  FOR  THIS  VAPI80LE  AT  CHAR.  NO.  . 

ERR  CR 

285 

$13) 

ERR  CR 

2 86 

GO  TO  1000 

ERR  CR 

287 

925 

WRITE(6«830)  INUM 

ERR  CR 

288 

810 

FORMAT (6X,52H  ILLEGAL  TTPE  IN  RELATIONAL  EXPRESSION  8T  CHAR.  NO.  , 

ERRCR 

289 

$131 

ERROR 

290 

GO  TO  1000 

ERR  CR 

291 

83  5 

WRITE(6,840)  INUM 

ERR  CR 

292 

840 

FORMAT  «6X,40H  TOO  MANY  ARGUMENTS  IN  CALLING  SEQUENCE  .13) 

ERRCR 

293 

GO  TO  1000 

ERR  OR 

294 

84  5 

WRITE  16.  650) 

ERROR 

295 

850 

F0RMAT(6X.4H  TOO  MANY  FUNCTION  REFS  IN  THIS  STATEMENT) 

ERR  CR 

296 

GO  TO  1000 

ERROR 

297 

85  5 

WRITE(6.860)  INUM 

ERROR 

298 

86  0 

FORMAT (6X.26H  INVALID  FORMAL  PARAMETER  . A6 ) 

ERRCR 

299 

GO  TO  1000 

ERR  CR 

300 

865 

WRITE<6.870)  INUM 

ERROR 

501 

870 

FORMAT  I6X. 19H  THE  FUNCTION  NAME  .A6.33H  MAY  HAVE  BEEN  PREVIOUSLY  M 

ERROR 

302 

• ISUSFO) 

ERROR 

303 

GO  TO  1000 

ERROR 

304 

875 

WRITEI6.880)  INUM 

ERROR 

305 

680 

F0PHAn6X,39H  ILLEGAL  FIELD  DESCRIPTOR  AT  CHAR.  NO.  ,14) 

ERR  OR 

306 

GO  TO  1000 

CY58A 

56 

885 

WRITE  16,890) 

CY58A 

57 

890 

FORMAT  (6X.38H  TOO  MANY  FUNCTION  DEFINING  STATE)€NTS) 

CY5  8A 

56 

GO  TO  1000 

CY58A 

59 

895 

WRITE(6,900I 

CY58A 

60 

900 

F0RMAT(6X,71H  TOO  MANY  EXTERNAL  REFERENCES  IN  THIS  STATEMENT  - PRO 

CV5  8A 

61 

$CESStNG  TERHINATFO) 

CY5  BA 

62 

GO  TO  1000 

CY58A 

63 

90  5 

WRITE (6.910) 

CY58A 

64 

910 

FORMAT  (6X.46H  STATEMENT  IS  TOO  LONG  - PROCESSING  TERMINATED) 

CY5  8A 

65 

GO  TO  1000 

CY58A 

66 

915 

WRITE(6,920) 

CY58A 

67 

9?0 

FORMAT  (6X.46M  SESCOMP  1I$T  OVERFLOW  - PROCESSING  TERMINATED) 

CY58A 

68 

GO  TO  1000 

CY58A 

69 

92  5 

WRITE (6. 930) 

CY58A 

70 

930 

FORMAT (6X.63H  OVERFLOW  OF  INTERFACE  DEFINITION  TABLE  - PROCESSING 

CY58A 

71 

$TERMINATEO) 

CY58A 

72 

GO  TO  1000 

CY58A 

73 

93  5 

WRITEI6.940) 

CY5SA 

74 

94  0 

FORMAT <6X, 32H  TOO  MANY  EQUIVALFNCEO  VARIABLES) 

CY58A 

75 

GO  TO  1000 

CX58A 

76 

94  5 

WRITE(6.950) 

CY58A 

77 

95  0 

FORMAT  (6K.61H  TOO  MANY  VARIABLES  IN  THIS  STATt)TNT  - PROCESSING  TE 

CY5  8A 

78 

$RMINATE0) 

CY58A 

79 

1000 

WRITE (6.1) 

ERR  CR 

307 

RETURN 

ERR  CR 

308 

END 

ERR  CR 

309 

SU8R0UTIM6  EKPR 

EXPR 

? 

COHMON  Aa3a6l«0<900lfIOTBL(8,500>,INITIO(3»  ,L  ASTI  0(  3 > • ISRCH  f 3 ) • 

RICH 

2 

♦ JPTR,N*M, JTyP ,LSTART*N2, IFNCNH.LOGIO.NKTIO, 10  TYP,NIO*LOC. 

CY98A 

80 

2 LTYP, ITYP, IBLKOT.MOOEt lERRf lOES 

RICH 

4 

C0HM0N/FUNC/IFNCRA(5«13)  • H AR  GS  • I ARCS  < 9 Q ) «FNCL0C(9  1 «NFUNC 

CY58A 

13 

COMHON/STRING/NTYPE,NSTR, SIR  15  001 

EXPR 

9 

C0HM0N/LIST/NLIST*NINTFC*ISUBLT  <2,?00l .INTFACC  300» 

EXPR 

6 

COHHON/BASBLK/IBL0Cf(<?90  0)  • NBL  OCK,  N6  « NBR  NCH 

CY58A 

14 

INTEGER  FNCL0C,0PRA<6) ,B I TPU T , B I TGFT 

EXPR 

8 

INTEGER  0«ASTRlK«0EEtE0UALS,STR,A,C0NHA, RPAR,8LANK 

EXPR 

9 

DATA  lOPRACn , ,1H>, IH)  ,1H,  /,  AS TR IK/ 1 H*/ , OEE/ 1 HO / 

EXPR 

10 

1 »E0UALS/lHs/,C0HMA/lH,/,fiPAR/lH>/,LPAP/lHf/*8LANK/lH  / 

EXPR 

11 

c** 

EXPRESSION  PROCESSOR 

EXPR 

12 

c** 

THIS  ROUTINE  ENCOOES  ARITHMETIC  ANO  LOGICAt  EXPRESSIONS 

EXPR 

13 

ANO  I/O  LI'JTS  FOR  INPUT  TO  THE  PARSER 

EXPR 

I** 

LP  = 0 

EXPR 

19 

NFUNC«0 

EXPR 

16 

K^O 

EXPR 

17 

I£XPSTrNBLOCK4  1 

EXPR 

18 

HARGS^O 

EXPR 

19 

?03  K«Ktl 

EXPR 

20 

GET  NEXT  LANGUAGE  ELEMENT  IN  STATEMENT 

EXPR 

21 

CALL  GNLE 

EXPR 

22 

C** 

NO  MORE  CHARACTERS  LEFT,  RETURN 

EXPR 

23 

IFCJTYP  ,EQ,  0)  RETURN 

EXPR 

24 

C** 

NOT  A SPECIAL  CHARACTER,  KEEP  GOING 

EXPR 

29 

IF  IJTYP  .NE,  11  GO  TO  20 

EXPR 

26 

IFILTYP  ,EQ,  9 .OR.  ITYP  ,EQ.  6)  GO  TO  2 

EXPR 

27 

IFCITYP  .EQ.  1 .OR.  ITYP  . EQ . 35»  GO  TO  1 

EXPR 

28 

GO  TO  5 

EXPR 

29 

c*» 

CHECK  FOR  ENO  OF  EXPRESSION  IN  “IF-  STATEMENT 

EXPR 

30 

C** 

equal  SIGN  TERMINATES  STRING 

EXPR 

31 

1 IFfOllJ  .EQ.  EQUALS)  RETURN 

EXPR 

32 

GO  TO  9 

E XPR 

33 

2 IFIOU)  .EQ.  RPAP  .ANO.  LP  . EQ . 1)  RETURN 

EXPR 

34 

c*» 

special  CHAPACTER  LOOP 

EXPR 

39 

9 00  10  1*1,6 

EXPR 

36 

IF(0<1)  .NE,  OPRA«II)  GO  TO  10 

EXPP 

37 

C** 

ENCOOE  special  CHARACTER 

EXP  R 

38 

STRCK) =-I 

EXPR 

39 

IF  (I  .EQ.  4)  GO  TO  6 

EXPR 

40 

IF  Cl  .EQ.  9)  GO  TO  7 

EXPP 

41 

GO  TO  100 

EXPR 

42 

C** 

LEFT  PAREN  FOUND  - INCRE^CNT  COUNTER 

EXPR 

43 

6 LP«LP41 

EXPR 

44 

CO  TO  100 

EXPR 

45 

C** 

RIGHT  PAREN  FOUND  - DECREMENT  COUNTER 

EXPR 

46 

7 LP*LP-1 

EXPR 

47 

GO  TO  100 

EXPR 

48 

10  CONTINUE 

EXPR 

49 

IFCDfl)  .NE.  EQUALS)  GO  TO  12 

EXPR 

90 

C** 

ENCOOE  equals  SIGN 

EXPR 

91 

STR(K) e-18 

EXPP 

9? 

GO  TO  100 

EXPR 

53 

12  IFCOUl  .NE.  ASTPIK)  GO  TO  110 

EXPR 

54 

IFCOC2)  .EQ.  ASTPIK  .ANO.  H .GT,  1)  GO  TO  19 

EXPR 

99 

c** 

ENCOOE  ASTRIK 

EXPO 

96 

i 


1 


I 


I 

A 


STff  «-7 

EXPR 

57 

GO  TO  too 

EXPR 

58 

C**  ENCODE  EXPONENTIATION  SIGN 

EXPR 

59 

15  ST9nO=-8 

EXPR 

61 

TO  100 

EXPP 

61 

?0  r»-<JTYP  ,NE,  7t  GO  TO  30 

EXPR 

62 

If  ILOGIO  .GT,  9)  GO  TO  25 

EXPR 

63 

C**  ENCODE  LOGiCAt  OPFPATOR 

EXPR 

64 

STR(f )*-(L0GI0^8» 

EXPR 

65 

GO  TO  100 

EXPR 

66 

C**  ENCODF  logical  CONSTANT 

EXPR 

67 

2 5 STB  («t  »sL  START  ♦4^0  000^H*1000000 

EXPR 

68 

GO  TO  100 

EXPR 

69 

TO  TFTJTYP  ,NE*  41  GO  TO  40 

EXPR 

70 

iniOES  .EO.  0>  ^-0  TO  35 

EXPR 

71 

C**  ENCODE  30U9LE  PRECISION  CONSTANT 

EXPR 

72 

STROO  sLSTART  ♦ 4 20  0 0 0 1 0 0 00  0 0 

EXPR 

73 

GO  TO  100 

EXPR 

74 

35  CONTINIJE 

EXPR 

75 

C**  ENCODE  real  constant 

EXPR 

76 

STRCKI =LST ART  ^40 0 000 ♦H* 10 00000 

EXPR 

77 

GO  TO  100 

EXPR 

78 

40  IFUTYP  .NE.  61  GO  TO  50 

EXPR 

79 

C**  ENCODE  COHPLEX  CONSTANT 

EXPR 

80 

STRfKI =LSTART ^41 0 000* H*l 000000 

EXPR 

Si 

CO  TO  100 

EXPR 

82 

50  IF  ejTYP  .NE.  5 1 GO  TO  55 

CY50A 

15 

C**  ENCODE  integer 

EXP  R 

84 

STR(*r»  rLSTaPr*430000»N*i  00000  0 

EXPR 

65 

GO  TO  100 

EXPR 

66 

55  IFUTYP  .NE,  3)  GO  TO  60 

CY58A 

16 

ST P (lO  *L ST  ART  *450  OOO^M*!  0 000  00 

CY58A 

17 

IFCITYP  ,NE.  81  call  EPR0R(?3) 

CY58A 

16 

GO  TO  100 

CY58A 

19 

60  IFUTYP  .NE,  21  GO  To  110 

EXPR 

87 

C**  YAPIAOlE  FOUND  - jEARCN  SY-flCt  TARtf 

EXPR 

80 

call  starch 

EXPR 

69 

ibeta*o 

EXPR 

90 

IFINFirTUPTRl  .NF,  LP*®!  GO  TO  64 

EXPR 

91 

IFIISRCHII)  ,EQ.  01  GO  TO  62 

EXPR 

92 

IF  (HI  I UOTflL  U *L'>CI  ,l  , 1 1 ,FQ,  l»  GO  TO  67 

EXPR 

93 

C**  variable  is  NOi  OlHENSIOTfO  - HUST  Bf  A FUNCTION 

EXPR 

94 

C*»  Change  storage  in  Syhboi  table 

EXPR 

95 

CALL  Switch 

EXPR 

96 

IBET4*6 

EYPP 

97 

GO  TO  63 

EXPR 

96 

C**  FUNCTION  REFERS  nCE 

E XPR 

99 

62  IflFTA#5 

EXPR 

100 

IF(lSRfH(?)  ,fO,  11  CO  TO  63 

EXPR 

101 

C»*  function  NOT  YFT  STOPFO 

EYPR 

102 

I0TYPS2 

EXPR 

103 

call  store 

e *p  R 

104 

LOC»NIO 

EXPR 

lOS 

no  TO  i»i,nlist 

EXPR 

106 

IF  ( ISUBLT  n ,11  ,NE.  1 D TBL ( 1 , LOC ) ) GO  TO  70 

EXPR 

107 

C*»  FUNCTION  NAHF  fOUNO  IN  SESCOHP  LIST 

EXPR 

108 

IF  (fli  rr.F  T ( ISUBLT  (2,  n , 10 ,41  ,NF.  41  GO  TQ  63 

f XPR 

109 

t 


C**  INTRINSIC  FUNCTION  - STORE  TYPE  IN  SYMBOL  TABLE 

EXPR 

110 

ITP=0ITGET(ISU0LT 13,1) ,13, 3> 

E*PR 

ill 

IOTBL  C3,L0C»*B ITPUT( IOT8L  <3,L0CI , ITP, 10> 

EXPR 

112 

IOTBH3,LOCl  = 0lTPUTaOT8L<3,LOCI  ,1,111 

EXPR 

113 

GO  TO  63 

EXPR 

114 

70  CONTINUE 

EXPR 

115 

C**  PUT  EUNCTION  IN  FUNCTION  LIST 

EXPR 

116 

63  NFUNCsNFUNC^l 

EXPR 

117 

IFfNFUNC  .GT.  5>  GO  TO  120 

CY58A 

20 

FNCLOC  (NEUNCI  =LOC 

EXPR 

118 

GO  TO  68 

EXPR 

119 

C»*  NON-OIMENSIONEO  VARIABLE 

EXPR 

120 

64  IF<ISRCH(2)  .NE.  1)  GO  TO  65 

EXPR 

121 

C»*  FUNCTION  NAME  NOT  FOLLONEO  BY  LEFT  PAREN,  MUST  BE  THIS  EUNCTION 

EXPR 

122 

lEINKTIO  *NE*  IENCNM)  CA LL  ERR OR ( 10 , NX TI 0) 

EXPR 

123 

C**  STORE  IN  SYMBOL  TABLE 

EXPR 

124 

65  lEIISRCHm  .EQ,  1)  GO  TO  67 

EXPR 

125 

lOTYPsl 

EXPR 

126 

CALL  STORE 

EXPR 

127 

LOC=NIO 

EXPR 

128 

GO  TO  68 

EXPR 

129 

C**  SET  dimensionality 

EXPR 

130 

67  I0ETAaPITGET(IOTBL(3,LOC) ,7,61 

EXPR 

131 

lECNXTIO  .HE.  IENCNM)  GO  TO  68 

EXPR 

132 

IBETAsO 

EXPR 

133 

LOC*IOES 

EXPR 

134 

68  CALL  IMPTYP 

EXPR 

135 

C**  SET  TYPE 

EXPR 

136 

IALPH=BITGET< IOTBL  <3,LOC) ,10 ,3) *1 

EXPR 

137 

JPTRs JPTR-1 

EXPR 

138 

C**  ENCODE  VARIABLE 

EXPR 

139 

STRIKI *LOC»10  0 00 •lALPH^lO 0000* IBETAt  1 000  000*M 

EXPR 

140 

100  NSTRaX 

EXPR 

141 

IFINSTP  .GT.  5 00  ) GO  TO  130 

CY58A 

21 

GO  TO  200 

EXPR 

142 

110  CALL  ERROR(23) 

EXPR 

143 

RETURN 

EXPR 

144 

120  CALL  ERROR<90) 

CY5  8A 

22 

STOP 

CY58A 

23 

130  CALL  ERROR(91 ) 

CV58A 

24 

STOP 

CX58A 

25 

END 

EXPR 

145 

SUBROUTINC  EXPRCK 

EXPRCX 

COMMON  « (1376)  ,0  (9001.  IOTBL  IS.f  10),  INITIOO)  .L  IST  IO(  3 1 , ISRCH  ( 3 1 . 

RICH 

• JPTR,N,N,JTTP,LST*RT,N7,  IFNCMN,L06I0,N)ITI0,  iottp.hio.loc. 

CY58A 

80 

7 ltyp.ittp.iblkot.mooe.ierr.ioes 

RICH 

CO  MM  OM/T  TP/moo,  RHSTTP,NQ7,NQ3.LHSTTP 

EXPRCK 

OI)CNSIO)(  1*19.9) 

EXPRCX 

intecer  rhsttp 

EXPRCX 

OAT*  (( I*  II. J ).  I<1. 9).  J*  1.9) /1. 0.0. 1.0.0  .1.0.0  .0.1. 0.1. 1.0. 

EXPRCX 

1 1.0. 1.1. 0.0. 0.0. 0.1/ 

EXPRCK 

C** 

THIS  ROUTINE  IS  CALLED  BT  THE  ASSICNNENT  ST*TE)«NT  PROCESSOR  TO 

EXPRCK 

C** 

CHECK  THE  "LEFT  SIDE  TYPE"  ANO  "RIGHT  SIDE  TYPE"  TO  SEE  IF  THE 

EXPRCK 

11 

C** 

ASSIGNMENT  IS  VALID 

EXPRCK 

11 

if(i*(lhstyp,rhsttp»i)  .eg.  o)  call  errorcet) 

EXPRCK 

1? 

RETURN 

EXPRCK 

13 

END 

EXPRCK 

14 

L 


t 

t 

i 
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SUBROUTlNf  FLOMCK 

FLOMCK 

3 

COHHON  A(1  336)  ,0  (500>«  IOTBlCB^SOOI  t INITI  013)  ,L  ASTIDO)  ,ISRCH(3)  * 

RIC  F 

3 

• JPTR,N*H, JTrP,LSTA9T,N2, IFNCNH ,L OGI 0 * NK T 10, 10 TYP, NIO t LOG  * 

CY58A 

80 

2 LTYP, ITYP, I0LKOT,HOOC, lePfff  tOFS 

RICH 

4 

COHMON/BASBK/IBL  OCK(2600)  tNBL0CK,N6,NB9NCH 

CYS8A 

50 

COMHON/OOLOOP/  ISTACK  )l»  *5  0)  •NSTACK  tILOOP*  lOVFLW 

FLOMCK 

5 

COMHON/LABELS/STATRA (3,20  0 ),  NL ABEL 

FLOMCK 

6 

COHHON/FLOM/IFL  » IRP 

FLOMCK 

? 

OIHENSION  IPATM( 100) , ISTCK  (100 ) 

FLOMCK 

8 

INTEGER  FLMLST (100) ,BRAHCH,STATRA 

»^LOMCK 

9 

INTEGER  BITPUT ,BITGET 

FLOMCK 

10 

equivalence  <IPATH(l),A(in,(tSTCK(l),A(101)),  (FLMLST  ( 1 ) , A ( 30 1 ) ) 

FLOMCK 

11 

C**  FlOM  analysis  algorithm  - CHECKS  EVERY  POSSIBLE  PATH  OF  FLOM 

FLOMCK 

13 

through  THE  program 

FLOMCK 

13 

IF  (IFL  ,EO.  -1)  GO  TO  3000 

FLOMCK 

14 

CLTM1*SECONO(T) 

FLOMCK 

15 

IRK«0 

FLOMCK 

16 

NSTCK*0 

FLOMCK 

ir 

NFLOMsQ 

FLOMCK 

18 

NOC«0 

FLOMCK 

19 

NPTMS*0 

FLOMCK 

30 

C**  START  MITH  first  BASIC  BLOCK 

FLOMCK 

31 

IBLKST»1 

FLOMCK 

33 

C**  SET  initially  DEFINED  VARIABLES 

FLOMCK 

33 

CALL  CMKLST 

FLOMCK 

34 

MRITE(6,8) 

FLOMCK 

35 

B FORMAT (1M1,38H******  RESULTS  OF  FLOW  ANALYSIS  ••••••//) 

FLOMCK 

36 

5 00  1C  1=1, NIO 

FLOMCK 

37 

10  IOTBL (3, I) >I0TBL (8,1) 

floick 

38 

13  IFfNFLOW  ,EO«  0)  GO  TO  30 

FLOMCK 

39 

NOC«0 

FLOMCK 

30 

C**  this  COMPUTES  THE  NUMBER  OF  DUPLICATE  OCClIRANCES  FOR  THE 

FLOMCK 

31 

C**  CURRENT  BASIC  BLOCK 

FLOMCK 

33 

00  15  I»1,NF10M 

FLOMCK 

33 

IF (lABS (FLHLS T (I  ) ) ,NE.  IBLKST)  GO  TO  15 

FLOMCK 

34 

NOC=NOC^l 

FLOMCK 

35 

15  CONTINUE 

FLOMCK 

36 

C**  TERMINATE  FLOM  ANALYSIS  FOR  THIS  PATH  IF  TOO  MANY  OCCURAFCES 

FLOMCK 

37 

IFCNOC  ,GT.  IRP)  GO  TO  1500 

FLOMCK 

38 

C»*  AOn  BLOCK  TO  CURRENT  FLOM  PATH 

FLOMCK 

39 

30  )#^LOM=NFLOM»l 

FLOMCK 

40 

IF(NFLOM  *GT.  100)  GO  TO  4000 

FLOMCK 

41 

FLMLST  (NFLOM)  «IBL  KST 

FLOMCK 

43 

C**  GET  ENO  OF  0L«K 

FlO)CK 

43 

IENO*BITGET  (I  BLOCKdRLKST)  ,3  8,  16)  -1 

FLOMCK 

44 

IFdENO  .EQ,  -1)  IENO*NBLOCK 

FLOMCK 

45 

C**  GET  NUMBER  OF  BRANCHES  FROM  BLOCK 

FLOMCK 

46 

NBP=BITGET (IBLOCK (IBLKST) ,6,6) 

FLOMCK 

47 

C**  GET  BLOCK  OF  t€tJ  BRANCH 

FLOMCK 

48 

istart*ieno-nbr^i 

FLOMCK 

49 

IBLKST *NYT9LK ( 1ST ART, I ENO) 

FLOMCK 

58 

IF(NBR  ,EQ,  1 ) GO  TO  35 

FLOCK 

51 

FLMLST  (NFLOM)  ■ -FLMLST  ( NFLOM) 

FLOMCK 

53 

C**  MORE  than  one  BRANCH 

FLOMCK 

53 

C**  STORE  NEXT  BLXK  ON  STACK  AS  NEGATIVE  NUMBER 

FLOMCK 

54 

NSTCK*NSTCK^1 

FLOICK 

55 

IF(NSTCK  ,GT.  lOO)  GO  TO  5000 

FLOMCK 

56 

ISTCK(NSTCKI«-HXTBLK(IENOt lENOI 

FLOMCK 

57 

ir<H6R  .EQ«  31  GO  TO  35 

FLOHCK 

58 

C**  HORE  THAN  TMO  BRANCHCS  * PUT  ALL  REMAINING  BRANCHS  ON  STACK 

FLOMCK 

59 

00  33  J<3*NBR 

FLOMCK 

60 

nstck«nstck^i 

FLOMCK 

61 

lECNSTCK  .GT«  100)  GO  TO  5000 

FLOMCK 

63 

3 3 ISTCKINSTCK>  = HXT0LKaENO-J»3,l  END) 

FLOMCK 

63 

35  IECI0LKST  *NE.  01  GO  TO  13 

FLOMCK 

64 

c»»  »Li  br*ncmes  h«ve  been  placed  on  current  flon  path  or  The  stack 

FLOMCK 

65 

C**  BEGIN  TRACING  THROUGH  PATH 

FLOMCK 

66 

NPATHsQ 

FLOMCK 

67 

C»*  INCREMENT  PATH  COUNTER 

FLOMCK 

68 

NPTHS=NPTHS*1 

FLOMCK 

69 

00  1000  I*l«NFLOM 

FLOMCK 

70 

C**  GET  next  block  IN  PATH 

FLOMCK 

71 

0RANCHsIABS(FLMLST(IU 

FLOMCK 

73 

C**  SET  POINTER  TO  FIRST  VARIABLE  IN  BLOCK 

FLOMCK 

73 

ISTARTsBRANCH^l 

FLOMCK 

74 

C**  get  START  OF  NEXT  BLOCK 

FLOMCK 

75 

NVBL0K*BITGET ( IBLOCK (BRANCH)  ,38,16) 

FLOMCK 

76 

IF(NXBLOK  .£Q.  0)  NXBL OK> NBL OCK ♦ 1 

FLOMCK 

77 

C**  GET  STATEMENT  NUMBER  OF  BLOCK 

FLOMCK 

78 

ISL-eiTGETdBLOCK  (BRANCH)  ,36,8) 

FLOMCK 

79 

C**  GET  00  LOOP  CONTAINING  BLOCK 

FLOMCK 

80 

IL00P  = BITGET( I BLOCK (BRANCH) ,13,6) 

FLOMCK 

61 

C**  GET  number  of  BRANCHES  FROM  CLOCK 

FLOMCK 

83 

NBRsBI TGET( IB LOCK (BRANCH) ,6,6) 

FLOMCK 

83 

C**  SET  POINTER  TO  LAST  VARIABLE  IN  BLOCK 

FLOMCK 

64 

IENO=NXBLOK-NBR»1 

FLOMCK 

85 

C**  BLOCK  HAS  STATEMENT  LABEL  - STORE  IN  STATEMENT  LABEL  LIST 

FLOMCK 

86 

C*»  SET  njSEO-  FLAG 

FLOMCK 

67 

IFdSL  ,EO.  0)  GO  TO  45 

FLOMCK 

88 

NPATHsNPATH^I 

FLOMCK 

89 

IPATH(NPATH)sST ATRA (1, ISL) 

FI OMCK 

90 

STATPA (3,ISL)  =BI TPUT(STATRA(3, ISL) ,1* 

18) 

FLOMCK 

91 

45  IF(IRLOCKdSTART)  ,LT,  lOQQ)  GO  TO  1000 

FLOMCK 

93 

C**  This  LOOP  EXAMINES  ALL  VARIABLES  IN  THE 

BL  OCK 

FLOMCK 

93 

no  500  j»istart,ieno 

FLOMCK 

94 

C**  get  variable  aASS  l - defined 

3 - REFERENCED  3-00 

index 

FLOMCK 

95 

C**  4 - ASSIGNED 

5 - referenced  by  ASSN, 

GOTO 

FLOMCK 

96 

C**  6 • MADE  UNOEFDCO  7-00  PARAMETER 

FLOMCK 

97 

IT=I6LOCK(J)/lOOO 

FLOMCK 

98 

C**  GET  SYMBOL  TABLE  LOCATION  OF  VARIABLE 

FLOMCK 

99 

L0C*I8L0CK( J) -IT* 1000 

FLOMCK 

100 

GO  T0(50 *60,70 ,80, BO, too ,3001 , IT 

FLOMCK 

101 

C**  VARIABLE  IS  DEFINED 

FLOMCK 

103 

so  IF(BITGET(I0TBL(3,L0C)  *13,1)  .FO.  1) 

GO  TO  130 

FLO)CK 

103 

IFdOTBL  (2*L0C)  *EQ.  3)  GO  TO  S5 

FLOMCK 

104 

IF  dOTBL  (2«LOC ) .EO,  4)  GO  TO  180 

FLOMCK 

105 

C**  SET  defined  FLAG 

FLOMCK 

106 

S3  lOTBL (?,LOC)= 1 

FLOICK 

107 

30  IF(BITGETdOTeL(3,LOCI  .17,1)  .EQ.  0) 

GO  TO  500 

FLOMCK 

108 

C**  variable  is  EOUIVAlENCEO  - GET  TYPE 

FLOMCK 

109 

KTYPFxPITGETI  lOT  BL(3,LOC)  ♦ 10  * 3) 

FLOMCK 

110 

C**  SET  ALL  variables  OF  SAME  TYPE  VHICH  ARE  EOUIVALENCEO  TO  THIS  ONE 

FLO  ICK 

111 

C**  TO  -OEFInEO- 

FLOMCK 

113 

C**  SET  ALL  variables  OF  DIFFERENT  TYPE  TO 

-UN  OEFI  0- 

FLOMCK 

113 

NXQV>*LOC 

FLOHCK 

114 

53  NXOVsIOTat  17,  NXQVI 

FLOHCK 

115 

IFCNXQV  ,EO«  LOO  CO  TO  500 

FLOHCK 

116 

IFieiTGET(I0T8L(3tNXQVI,10,3)  .EQ.  KTYPE  1 GO  T0  6<i 

FLOHCK 

117 

lOTBL (2f NXQV) >0 

FLOHCK 

118 

GO  TO  53 

FLOHCK 

119 

54  lOTBl  (?,NXQV)  «t 

FLOHCK 

120 

GO  TO  53 

FLOHCK 

121 

c**  flag  indicates  that  variable  was  once  a 00 

INOfX 

FLOHCK 

122 

C**  HAKE  SURE  THAT  IT  IS  NOT  CURRENTLY  A DO  INDEX 

FLOHCK 

123 

55  IFatOOP  .EQ,  01  GO  TO  52 

FLOHCK 

124 

57  IFILOC  .EQ.  ISTACK(4,IL00PII  GO  TO  110 

FLOHCK 

125 

IFaSTACKC3,ILOOP>  .EQ.  0)  CO  TO  52 

FLOHCK 

126 

ILOOPsrSTACKI3, ILOOP> 

FLOHCK 

127 

GO  TO  57 

FLOHCK 

128 

C**  VARIABLE  IS  REFERENCED 

FLOHCK 

129 

C**  IF  undefined  or  ASSIGNED,  ISSUE  DIAGNOSTIC 

FLOHCK 

130 

60  IFCI0TBL(2,L0CI  .EQ.  0)  GO  TO  140 

FLOHCK 

131 

IFIIDTBL(2,LOC>  .EQ.  3)  GOTO  130 

FLOHCK 

132 

C*»  SET  “REFERENCED"  FLAC 

FLOHCK 

133 

GO  TO  500 

FLOHCK 

134 

C*«  VARIABLE  IS  A DO  INDEX 

FLOHCK 

135 

70  IF(BITGETaOTBL(3, LOCI  ,13,1)  «EQ.  11  GO 

TO  1?0 

FLOHCK 

136 

IF CIOTBL I2,L0C • .EQ.  2)  GO  TO  75 

FLOHCK 

137 

C**  SET  “DO  INDEX-  FLAG 

FLOHCK 

138 

72  IDTBL C2,L0C)=2 

FLOHCK 

139 

GO  TO  500 

FLOHCK 

140 

c*»  flag  indicates  that  variable  has  once  a do 

INOfX 

FLOHCK 

141 

C**  HAKE  SURE  THAT  IT  IS  NOT  CURRENTLY  A DO  INDEX 

FLOHCK 

142 

75  IFIILOOP  .EQ.  0)  CO  TO  72 

FlOfcCK 

143 

77  IFCLOC  .EtJ.  ISTACK(4«  ILOOPII  GO  TO  110 

FLOHCK 

144 

IMISTACKI3,IL  OOP)  .EO.  0)  GO  TO  72 

FLOHCK 

145 

ILOOP»ISTACK<  3,ILOOP) 

FLOHCK 

146 

GO  TO  77 

FLO  K,K 

147 

C**  VARIABLE  IS  ASSIGNED 

FLOHCK 

148 

SO  TFIBITGET  (lOTBL  C3,LOC)  ,1  3, 1)  .EQ.  1)  GO 

TO  120 

FLOHCK 

149 

IFCIOTBLf2,LOC)  .EQ.  2)  GO  TO  S5 

FLOHCK 

150 

C**  SET  “ASSIGNED"  FLAG 

FLOHCK 

151 

82  IDT8L I2.L0C)= 3 

FLOHCK 

152 

GO  TO  500 

FLOHCK 

153 

C^*  flag  INDICATES  THAT  VARIABLE  WAS  ONCE  A 00 

INOFX 

FLOHCK 

154 

C**  HAKE  SURE  THAT  IT  IS  NOT  CURRENTLY  A DO  INDEX 

FLOHCK 

155 

S5  lEHLOOP  .EQ.  01  GO  TO  82 

FLOHCK 

156 

87  IF(LOC  .EQ.  I S TAC  K 14  , I LOOP ) ) GO  TO  110 

FLOHCK 

157 

IF(ISTACK(3,UOOP)  ,EQ.  0)  GO  TO  82 

FLOICK 

158 

IL  OOP»ISTACKC3 , ILOOP) 

FLOHCK 

159 

GO  TO  87 

FLOHCK 

160 

C»*  VARIABLE  IS  REFERENCED  BY  ASSIGNED  GO  TO 

FLOHCK 

161 

C**  HAKE  SURE  VARIABLE  HAS  ASSIGNED 

FLO  kCK 

16? 

50  IF  IIOTBL <2,LOC)  .NE.  3)  GO  TO  150 

FLOHCK 

163 

GO  TO  500 

FLOHCK 

164 

C**  VARIABLE  IS  HAOE  UNDEFINED 

FLOHCK 

165 

100  IDTBL(2,LOC)=0 

FLO  KK 

166 

GO  TO  500 

FLOHCK 

167 

THIS  LOOP  CHECKS  TO  SEE  IF  A DO  PARAMETER 

HAS  BEEN  REOEFINEO 

FLOHCK 

168 

18  0 JLOOP*BITGETeiOTBL<3,LOC)  ,36,18) 

FLOHCK 

169 

185  IFULOOP  .EO.  JLOOP)  GO  TO  160 

FLOICK 

170 

rL00P*rsT4C«c(  j,rLOOP» 

FLO  ICK 

171 

IFUIOOP  .EQ.  0)  GO  TO  30 

FLOMCK 

173 

GO  TO  185 

FLOMCK 

173 

C**  VARIABLE  IS  A DO  PARAHETER 

FLOWCK 

174 

C**  IF  UNDEFINED  OR  ASSIGNED  ISSUE  DIAGNOSTIC 

flonck 

175 

?00  IF (IDTBL  l?«LOC ) *EQ.  0)  GO  TO  1%0 

FLONCK 

176 

IF<IOTBL (?«LOC)  .CO.  3)  GO  TO  130 

FLOWCK 

177 

lOTBL I2*L0CI«% 

FLOWCK 

176 

GO  TO  500 

FLOWCK 

179 

C**  SET  ERROR  COOES 

FLOWCK 

ISO 

110  IERC*67 

FLOWCK 

161 

GO  TO  400 

FLOWCK 

163 

130  IERC=66 

FLOKCK 

163 

GO  TO  400 

FLOWCK 

164 

130  IERC-69 

FLOWCK 

165 

GO  TO  400 

FLOWCK 

186 

140  IERC-70 

FLOWCK 

167 

GO  TO  400 

FLOWCK 

166 

150  IERCS71 

FLOWCK 

169 

GO  TO  400 

FLOWCK 

190 

160  IERC*72 

FLOWCK 

191 

400  IRV«1 

FLOWCK 

193 

C**  SET  ERROR  FLAG  AND  ISSUE  DIAGNOSTIC 

FLOWCK 

193 

IF  fBlTGETdOTBLn.LOCI  tl5*l)  .EQ.  11  GO  TO  500 

FLOWCK 

194 

rOTBL  l3«L0CMBITPUT(I0T6Lf  3«LOC)  « ltl5> 

FLOWCK 

195 

CALL  ERRORdERCtIDTBLdtLOCn 

FLOWCK 

196 

IFdERC  .NE*  70  .OR.  NPATH  .EQ.  01  GO  TO  500 

FLOWCK 

197 

HRITEC6t410)  ( IPATHHO  ,K«1*NPATHI 

FLOWCK 

196 

410  FORMAT I6X*15H  ALONG  THE  PATH, (1016)1 

FLOWCK 

199 

500  CONTINUE 

FLOWCK 

300 

1000  CONTINUE 

FLOWCK 

301 

SCANNING  OF  THIS  PATH  COMPLETE  - GET  NEXT  PATH 

FLOWCK 

303 

C*»  STARTING  FROM  BOTTOM  OF  FLON  PATH,  FIND  FIRST  NEGATIVE  NUMBER 

FLOWCK 

303 

150  0 IF(FLMLST(NFLOMI  ,GT,  0)  GO  TO  1600 

FLOWCK 

304 

€••  NEGATIVE  NUMBER  FOUND  - TARE  NEXT  BRANCH  FROM  TOP  OF  STACK 

FLOWCK 

305 

IBLKST«IA6SaSTCK(NSTCK) ) 

FLOWCK 

306 

IFCISTCKINSTCK)  .LT.  0>  FLNLST ( NFLON) * -F INLS T OT L ON) 

FLOWCK 

367 

NSTCK*NSTCK-l 

FLOWCK 

306 

NOC<0 

FLOWCK 

309 

GO  TO  5 

FLOWCK 

311 

1600  )TLOHsNFLOH-l 

FLOWCK 

311 

IFCNFLOM  .GT,  01  GO  TO  1500 

FLOWCK 

313 

CR*  NO  MORE  BRANCHES  LEFT 

FLOWCK 

313 

IFCNLABEL  •EQ.  0)  60  TO  3010 

FLOWCK 

314 

this  loop  checks  to  see  if  STKTEHEMT  l»8ELS  here  »ll  referemceo 

FLOWCK 

315 

00  2000  J'ltNLIBEL 

FLOWCK 

316 

IF(BITGET(ST*TR«I2,JI,6,6I  .EQ.  201  GO  TO  2000 

FLOWCK 

317 

IFIBIT6ET(ST*TRtl2.JI,lB,3l  .EQ.  11  GO  TO  2000 

FLOWCK 

316 

HRITEI6,  18001  ST«TR«ll,Jt 

FLOWCK 

319 

IR*«1 

FLOWCK 

330 

1800  F0RH»T(6X,5rH  THERE  IS  NO  COHPlETE  PATH  THAT  CONTAINS  STATENENT  NU 

FLOWCK 

331 

1NBER.I6I 

FLOWCK 

333 

2000  CONTINUE 

FLOWCK 

333 

2010  IFIIRK  .EQ.  01  NRITE(6.2020) 

floick 

334 

2020  FORHAT(//6X,18H  NO  ERRORS  FOUND) 

FLOWCK 

335 

MRITE  (6,2180)  NPTNS 

FLOWCK 

336 

2100  F0RNAT(//////6X,2SH  NUNBER  OF  PATHS  CHECKED-, 16) 

FLOtCK 

337 

CLTM2*SECONO(T) 

FLOWCK 

336 

TOTTIN.CLTN2-CLTH1 

FLOtCK 

339 

HRITEI6,2T00)  TOTTIN 

FLOWCK 

331 

2700  FORMAT  (//66X,20H  FLON  ANALYSIS  TOOK  ,F8.  3,11H  CP  SECONDS) 

FLOWCK 

331 

RETURN 

FLOWCK 

333 

3000  MRITE(6,3001) 

FLOWCK 

333 

3001  FDRNAT  (//31X,S7H  FLON  ANALYSIS  MAS  NOT  PERFORMED  DUE  TO  ERRORS  IN 

FLOWCK 

334 

tPROGRAH) 

FLOWCK 

315 

IFL-IRPYl 

FLOWCK 

336 

RETURN 

FLOWCK 

337 

6000  MRITE  (6,6001) 

FLOWCK 

336 

6001  FORMAT  (//2BX,63N  TABLE  OVERFLOM  DURING  FLOM  ANALYSIS  - FLON 

ANALVS 

FLOWCK 

339 

SIS  TERMINATED) 

FLOWCK 

340 

return 

FLOWCK 

341 

8000  MRITE(6,8001) 

FLOWCK 

343 

8001  FORMAT  (F/28X,63H  STACK  OVERFLOM  DURING  FLON  ANALYSIS  - FLOM 

ANALVS 

FLOICK 

343 

tIS  TERMINATED) 

FLOWCK 

344 

return 

FLOWCK 

345 

END 

FLOWCK 

346 

SU8l?0UTINe  FMCSTR 

fncstr 

2 

COMMON  Af 13261  ,0<500) • IOTeL<8*500>  t INITI 0(3) ,1 A$TI0(3) • X$RCH(3I« 

RICH 

2 

• *IPTR»NrM,JTf  P,LSTART,N2,IFNCNH*LOGlOtMATIO*  10  TY  P*MI  0*  L OC  , 

CY56A 

60 

2 LTYP* ITYP,IBIKOT,MOOE*IERR*IOFS 

RICH 

k 

C0MM0N/FUNC/IFNCPA(9,12) , M ARCS t I ARCS ( S 0) ,FNCL0Cf9) ,NFUNC 

CY5  6A 

37 

COMMON/L IST/NLIST.NINTFC* ISUBlT (2,2001 tINTFAC( 300) 

FNC  5TR 

5 

INTEGER  FNCLOC *eiTPUT,BITGET 

fncstr 

6 

c** 

THIS  ROUTINE  IS  CALLED  AFTER  PARSING  AN  EXPRESSION,  TO  PROCESS 

FNC  ST  R 

7 

c** 

ALL  FUNCTION  REFERENCES  IN  T^C  EXPRESSION 

Fncstr 

6 

IF(NFUNC  .EQ.  01  RETURN 

FNC  STR 

9 

00  60  Isl,NFJNC 

fncstr 

10 

c** 

GET  SYMBOL  TABLE  LOCATION  OF  NEXT  FUNCTION 

fnc  rrp 

11 

L0C*FNCL0C(I) 

fnc  str 

12 

c** 

SKIP  IF  statement  function 

fncstr 

13 

IF  (BITGET  (lOTBL  (3,L0C)  flB,!)  ,EQ,  1)  GO  TO  50 

fncstr 

16 

c** 

GET  NUMBER  OF  ARGUMENTS 

fncstr 

15 

NARGsIFNCRAd,  1) 

fncstr 

16 

IVAR=0 

FNCSTR 

IT 

c** 

GET  FUNCTION  TYPE 

fncstr 

16 

iTPsBITGETdOT  BL  (3fLOC)flO*3) 

FMCSTR 

19 

IF(BITGET(IOTBL(3,LOC)«1S«U  -EQ.  1)  GO  TO  20 

fncstr 

20 

c** 

FUNCTION  NAME  HAS  NOT  YET  APPEARED  IN  PROGRAM  - SET  FLAG 

fncstr 

21 

I0T6LI3,L0C)sBITPUT (lOTBL ( 3, L OC ) , 1» 1 6 1 

fncstr 

22 

c** 

search  SFSCOMP  list  for  NAME 

fncstr 

23 

DO  5 JsltNLIST 

fncstr 

26 

IF(IDTBL(l,LOC)  *NE,  ISUBLT(l,J)l  GO  TO  5 

fncstr 

25 

c** 

NAME  FOUND  - STORE  SESCOMP  LIST  LOCATION  IN  SYHBa  TABLE 

fncstr 

26 

IDTBL(3,LOC)=BITPUT(IOTBL(3«LOC) t J«36) 

fncstr 

27 

LISTLC*J 

PMC  fTP 

26 

GO  TO  21 

FNCSTR 

29 

5 CONTINUE 

fncstr 

36 

NAME  NOT  FOUHQ  IN  SESCOMP  LIST  • ISSUE  DIAGNOSTIC 

FNCSTR 

31 

CALL  ERROR(52) 

Fnc  str 

32 

c** 

STORE  NAME  IN  SESCOMP  LIST 

fncstr 

33 

NLIST«NL1ST»1 

FNCSTR 

36 

IF(NLIST  .GT,  20Q)  GO  TO  60 

CY5  8A 

36 

ISUBLT  (l«NLIST)*IOTBL(ltLOC) 

fncstr 

35 

c** 

STORE  LIST  LOCATION  IN  SYMBOL  TABLE 

fncstr 

36 

I0T6L (3,LOC)>BITPUT (IOTBL (3«LOC) ,NLIST,3€) 

fncstr 

37 

c** 

INCREMENT  INTERFACE  DEFINITION  TABLE  POINTER 

FMCSTR 

36 

IPTR*HINTFC^l 

fncstr 

39 

IFdTYP  «EQ«  S *ANO,  I «EO.  D ITP«0 

fncstr 

60 

c** 

STORE  INTERFACE  DEFINITION  TABLE  POINTER  AND  FUNCTION  TYPE  IN 

FMCSTR 

61 

c** 

SESCONP  LIST 

FNCSTR 

62 

ISUBLT  (2*NLIST)«0ITPUT(IPTR,ITP,  13) 

FNCSTR 

63 

c** 

STORE  NO.  OF  ARGUMENTS  IN  SESCOMP  LIST 

FMCSTR 

66 

ISUBIT(2,NLIST)«0ITPUTCISU0LT(2,MLIST)  ,NARG»6) 

FMCSTR 

65 

c** 

UPDATE  INTERFACE  DEFINITION  TABLE  COUNTER 

FNCSTR 

66 

NINTFC«IPTR^(NARG-1)/6 

FNCSTR 

67 

IF(NINTFC  .GT.  300)  GO  TO  7Q 

CY56A 

39 

c»* 

STORE  INTERFACE  DEFINITION 

FMCSTR 

66 

00  10  J»IPTR,  NINTFC 

FNt:STR 

69 

10  IMTF»C(J»«IFNC*»II.J-IPT»*2» 

FNCSTR 

56 

CO  TO  40 

FNCSTR 

51 

c** 

FUNCTION  NONE  M»S  PREVIOUSLY  OCCUREO  - 6ET  SESCO»  LIST  LOCOTION 

FNCSTR 

52 

?o  trsrtc*9ircfT»  lorst  i3,loo  .js.  9> 

FMCSTR 

53 

c»* 

get  interfrce  definition  t»ble  pointer 

FNCSTR 

56 

c** 


C** 


c** 


21  IPTR«aiT6ET(ISUBLT(2,LISTLCI .60,151 

FNC  STR 

55 

IFietTGETIISUSLTIZ.LISTLCI  ,16,11  .EQ.  11 

GO  TO 

22 

fncstr 

56 

' GET  NO.  OF  ARGUHENTS  AND  CHECK  VALIDITY 

FNC  STR 

57 

NARZ«BITGET(ISUBLT(2,LISTLCI  ,6,61 

FNCSTR 

58 

IFINARG  ,NE.  NAR2I  CALL  ERROR  1 ?6,  lOTBL  (1 

bLOCU 

FNCSTR 

59 

nargs<ninoinarg,narzi 

fncstr 

60 

GO  TO  26 

fncstr 

6i 

' VARIABLE  NO.  OF  ARGUMENTS  • SET  FLAG 

FNCSTR 

62 

22  IVAR>1 

FNC  STR 

63 

IFINARG  ,LT.  2)  call  E RROR  126  , IOTBL  1 1 . LOCI) 

FNCSTR 

64 

NARGS«NARG 

fncstr 

65 

' SET  ARGUMENT  TYPE  AND  01  * NS  lONAL  ITY 

FNCSTR 

66 

ITP1»BITGET(INTFACIIPTRI  ,3,3) 

FNCSTR 

67 

N0IN1*6ITCET(INTFACI  IPTRI  ,6.31 

fncstr 

68 

26  IFIITYP  .EO.  S .AND.  I .EO.  1)  GO  TO  25 

FNC  STR 

69 

IF  IBITGETIISUBLT  I2,LISTLCI  .10, 6)  .EQ.  6) 

GO  .0 

25 

FNCSTR 

71 

‘ CHECK  TYPES  OF  INTRINSIC  FUNCTIONS 

fncstr 

71 

JTP*BITGETIISUBLT  I2,LISTlCI,13,3I 

fncstr 

72 

IFIJTP  ,NE.  ITP)  call  ERR0R(69,I0TBLI1,L0CII 

FNC  STR 

73 

‘ SCT  INTERFACE  DEFINITION  TABLE  POINTER 

FNCSTR 

74 

E5  NOPTR«IPTR4<NARGS-n/6 

FNCSTR 

75 

KOUNTsO 

FNCSTR 

76 

THESE  TNO  LOOPS  CHECK  THE  ARGUHCNT  LIST  AGAINST 

the 

fncstr 

77 

^ INTERFACE  DEFINITION 

FNCSTR 

78 

DO  12  K*IPTR*N0PTR 

FNCSTR 

79 

ICOLl*-6 

FNC  STR 

80 

ICOL2»“3 

FNC  STR 

81 

00  32 

FNCSTR 

82 

KOUNT«KOUNT^1 

FNC  STR 

83 

IFIKOUNT  .GT*  NARGSI  GO  TO  40 

FNCSTR 

84 

ICOLl*ICOLl^B 

FNCSTR 

85 

ICOL2*ICOL2*B 

FNCSTR 

86 

IFCIVAR  .EQ*  n GO  TO  26 

FNC  STR 

87 

‘ GET  ARGUHENT  type  ANO  DIMENSIONALITY  FROM 

symbol 

table 

FNCSTR 

88 

ITPlxSITCET  (INTFACCK)  • IC0L1*3> 

FNCSTR 

89 

N0IM1xBITGET«INTFAC<K) »ICOL2*3l 

FNCSTR 

90 

2 6 ITP2*BITGET  <IFNCRA(I,K-IPTR^2) ,IC0L1«S) 

fncstr 

91 

NDIM2sRITGET< IFNCRA<I*K- IPTR»2I ,ICOL2*3l 

FNCSTR 

92 

CHECK  DIMENSIONALITY  ANO  TYPE  FOR  VALIDITY 

FNCSTR 

93 

IFINDIHl  «NE.  NOIM^)  CALL  ERROR  ISO « K OUNTI 

FNCSTR 

94 

IFCITP2  .EQ«  01  GO  TO  32 

FNC  STR 

95 

IFfITPl  bEO.  0»  G0  to  28 

fncstr 

96 

IFdTPl  .NE.  ITP2)  call  E RROR  < S 1 , KOUNT  I 

FNCSTR 

97 

GO  TO  32 

FNCSTR 

98 

2 8 INTFAC  IKM0ITPUTI  INTFACIKI  •ITP2,IC0L1I 

FNCSTR 

99 

12  CONTINUE 

FNCSTR 

100 

GO  TO  40 

FNCSTR 

101 

‘ STATEMENT  FUNCTION  - CALL  STATEMENT  FUNCTION  PROCESSOR 

FNCSTR 

102 

50  CALL  STFNCm 

CY5  8A 

40 

40  CONTINUE 

fncstr 

104 

RETURN 

FNC  STR 

105 

60  CALL  ERROR(B2l 

CY5  8A 

41 

STOP 

CY5  8A 

42 

70  CALL  ERRORIBII 

CY58A 

43 

STOP 

CY58A 

44 

END 

FNC  STR 

106 

FORTRAN  Version 


SUBROUTiNe  fORH  f09H2  2 

COMMON/L  V4RGS/L  VFUNCtL  VVARG,  LVV40*L  VVPOS  *L  VVTYP,  LWAL  t 

♦ LVHEAO .L  VVNVL i L V OEST , L VV ALSt 1 0 > ,UVTYPE  <1 01 *L VS  KIP 
COBHON/LVTABt/LVTSiZ.LVHAPI  1 ) /L  V VSEQ /I  VS  IZ  E,  L VSOSP  < 11 


COHMON  /ML/  HOL, ACTION, FUNC1,FUNC2,FUNC3,LFFT, right, STRING 

FOPM2 

3 

COHNON  /VAR/  VFOP, NCHAR, NCHAPP, CHAR, NOIC T 

FORM2 

4 

COMMON  /TYP/  NARRAY,TrPEl,TYPF2,ERRFLG 

FORM? 

5 

COMMON  /STRING/  NT YPE , NS ^ R *STR 

FOPM2 

6 

INTEGER  BITPUT ,BITGET 

FORM2 

7 

INTEGER  VF0RU5)  ,CHAR,STRCU 

FORH2 

8 

LOGICAL  ERRFLG 

F0RM2 

9 

GO  TO  25000 

CONTINUE 

IFfCHAR  ,NE.  IHXI  NOICTs-NL*  * 

FORM? 

11 

ncharp=ncharp»i 

FORM? 

12 

stpincharp»=noict 

FORM? 

13 

IFf.NOT,  ERRFLGI  RETURN 

FORM 

14 

ncmarsnchar^i 

FORHc 

15 

NC*1» (NCHARP-l ) /8 

FORM? 

16 

ICHAR=eiTGETlCHAR,6,6» 

FORM? 

17 

VFOR  (NO  sBITPUT  ( VFOR(NC)  , I CH AR  , 6 *NCHA R » 

FORM? 

18 

IFfNCHAR  ,EQ,  8)  NCHARsQ 

FORM? 

19 

PE  TUPN 

25000  continue 

GO  TO  25001 
FNO 


GIRL  Version 


2 

3 

k 

5 

6 

7 

8 
5 

18 

11 

12 

13 

Ik 

15 

16 

17 

18 

19 

20 


t SUBROUTINE  FORN  FORM2 

COHMOH  /HL/  HOt* ACTION, FUNCl «FUNC2*FUNC3 »LEFT, RIGHT, STRING  FORN? 

CONHON  /VAR/  VF0R,NCHAR,NCHARP,CHAR,N0ICT  FORN2 

COHNON  /TYP/  NARRAV,TYPE1,TYPE2,ERRFL6  FORK2 

CONHON  /STRING/  N TYPE , NS T R ,STR  F0RM2 

INTEGER  BITPUT,BITGET  FORH2 

INTEGER  VFORf 151 ,CHAR,SrRfll  FORH2 

LOGICAL  ERRFLG  FORM2 

G EXECUTE  FORN2 

IFICHAR  ,NE,  IHX)  N0ICT»-N0ICT  F0RH2 

NCHARPsNCHARP^l  FORK2 

STRCNCHARPMNO  ICT  FOtiH2 

IFUNOT,  ERRFLG)  RETURN  FORH2 

NCHAR«NCHARn  FORH2 

NC«1» (NCHARP- 11/0  FORM2 

ICHAR»eiTG£T<CHAR,6,6»  FORH2 

VFORINCI sBITPUT(VFOR(NCI , ICHAR, 6*NCMAR)  F0RH2 

IFCNCHAR  .EQ*  8)  NCHAR«0  F0RN2 

G COHPLETE  F0RH2 


SU0ROUTIME  rORMCt 

FORH 

2 

COHHON  « (13261 ,D (SOOI t tOTBLCS, 

5 00  1,INITID(3I  .LASTIOI3I  ,ISRCH(3), 

RICH 

2 

• JPTR,N,H,JTTP,lST»RT,N2,  IPNCNH.LOCID.NXTIO,  IOTYP.NIO.LOC, 

CY5  8A 

60 

2 LTTP.ITYP.IBLXOT.NOOE.IERR, 

lOES 

RICH 

INTEGER  B(Sat  .OtBITGET 

FORM 

% 

• THIS  ROUTINE  IS  CALLED  BY  “GHE" 

TO  PROCESS  LANGUAGE  ELEMENTS 

FORM 

5 

GO  Tou00«10,^0,30«<»0«50f  loa 

,1001 .JTYP 

FORM 

6 

* PACK  NAHE  INTO  SINGLE  WORD  ANO 

STORE  IN  -NXTIO* 

FORM 

7 

10  CALL  C<iAlOtN,NXTIOI 

FORM 

8 

RETURN 

FORM 

9 

eo  00  2S  i>i«io 

FORM 

10 

IFCOin  bNE.  1NH>  go  to  29 

FORM 

11 

• GET  SHE  Of  HOLLERITH  STRING 

FORH 

12 

CALL  CAIfO«t-t ,N3I 

FORH 

13 

IF(N2  .LT.  11  GO  TO  110 

FORM 

1% 

t^H2*l 

FORM 

15 

IF(N  .GT«  SQO)  CALL  ERRORfS) 

FORM 

16 

jptr«lstart»h 

FORM 

17 

• CHECK  EOR  NON-STANDARD  CHARACTER 

IN  STRING 

FORM 

16 

IST»I*1 

FORM 

19 

DO  22  J»IST,H 

FORM 

20 

ICHAR>BITGET(D  Ml  .6,61 

FORM 

21 

lEdCHAR  .GT.  57BI  GO  TO  12B 

FORM 

22 

22  CONTINUE 

FORH 

23 

ZFItrrP  .£0.  281  RfTURN 

FORM 

IF(N2  .GT.  Gl  CALL  ERR0R(5I 

FORM 

25 

RETURN 

FORM 

26 

2S  CONTINUE 

FORM 

27 

CALL  ERR0RI3I 

FORH 

26 

RETURN 

FORM 

29 

• CHECK  VALIDITY  OF  REAL  NUMBER 

FORM 

30 

30  CALL  CARIO.M, lOESI 

FORM 

31 

return 

FORM 

32 

> CHECK  VALIDITY  DF  INTEGER  AND 

STORE  VALUE  IN  -N3- 

FORM 

33 

60  CALL  CAII0.N.N2I 

FORM 

36 

RETURN 

FORM 

35 

• CHECK  validity  of  complex  NUMBER 

FORM 

36 

50  DO  55  I»2,M 

FORH 

37 

IFIOIII  .EQ.  IH.I  GO  TO  60 

FORM 

36 

55  B(I-1I«0(I) 

FORH 

39 

60  CALL  CARIB, 1-2, IDES) 

FORM 

60 

M2»M-I-1 

FORM 

61 

DO  65  J*1,M2 

FORM 

62 

65  BIJMOdYJI 

FORM 

63 

CALL  CARIB. M2, lOESI 

FORM 

66 

110  RETURN 

FORH 

65 

110  CALL  ERRORiri 

FORM 

66 

RETURN 

FORH 

67 

120  CALL  ERRORI23I 

FORH 

66 

RETURN 

FORH 

69 

END 

FORH 

50 

SUBROUTINE  FPHAT 

FRMAT 

2 

COHNON  A (13Z6)  .0  (60  0).  IOTB(.(«t  SI)0)>INITIO(3)  ,L  AS  TIO  ( 3 ) . ISRCH 1 3 > , 

RICH 

2 

JPTR*N,H,JTYP ,L START fN2* IFNCNH* 

LOGIO,  NXTIO.  iotyp.nio.lcx:. 

CY5SA 

80 

2 

LTYP* ITYP,IBL  KO T , MODE  * I ERR, IDES 

RICH 

k 

COMMON/FORNAT/  lOESST.IOESNO.  IGPST.ICPNO,  IGRP  .SEPST.SEPNO, 

CY5  0A 

2 

1 

DIR, ICON, ISEP 

FRMAT 

5 

DIMENSION  RPLOC(?0),IALPH(6) 

FRMAT 

6 

INTEGER  A,RPLOC,AICH,RPAR, BLANK, 

SEPST.se PNO.OIR 

FRMAT 

7 

DATA  8LANK/1H  / , A ICH/1 HH / ,LP AR /I H |/, RP AR /I H) / 

FRMAT 

8 

DATA  (lALPHm  , I > 1 ,6 ) / IMF  , IHO,  1 HR  , IHN,  IH  A,  1 HT/ 

FRMAT 

9 

this  ROUTINt  PROCESSES  FORHAT  STATEHENTS  A NO  RETURNS 

FRMAT 

10 

IFRMT*1  - VALID  IFRMAT»0 

- INVALID 

FRMAT 

11 

IFRMTsO 

FRMAT 

12 

C**  CHECK  SPELLING 

FRMAT 

13 

00  k I~lfb 

FRMAT 

ik 

IF(NEKTIJPTR)  • NE • IALPH(I)I  GO 

TO  70 

FRMAT 

15 

% 

CONTINUE 

FRMAT 

16 

NSTARTsJPTR 

FRMAT 

17 

IF CNEXT( JPTRI  .NE.  LPAR»  GO  TO  70 

FRMAT 

18 

00  10  1=1, N 

FRMAT 

19 

IFIITYPE  IJPTRI  .EQ.  2)  GO  TO  1 

FRMAT 

20 

IFCJPTR  .GT.  N>  GO  TO  12 

FRMAT 

21 

GO  TO  10 

FRMAT 

22 

1 

JPTRsJPTR-1 

FRMAT 

23 

CALL  GNLE 

FRMAT 

24 

IFCJTYP  .NE.  3)  GO  TO  10 

FRMAT 

25 

J1=JPTR-1 

FRMAT 

26 

IH=0 

FRMAT 

27 

C**  PUT  BLANKS  IN  HOLLERITH  STRINGS 

FRMAT 

28 

00  5 J=LSTART,J1 

FRMAT 

29 

IF(IH  .EO.  1»  GO  TO  3 

FRMAT 

30 

IF(A<JI  .EQ.  AICH)  IH>1 

FRMAT 

31 

GO  TO  5 

FRMAT 

32 

3 

A( J)«BLANK 

FRMAT 

33 

5 

CONTINUE 

FRMAT 

34 

10 

CONTINUE 

FRMAT 

35 

12 

NPARsQ 

FRMAT 

36 

NRP*0 

FRMAT 

37 

00  20  i=nstart,n 

FRMAT 

38 

IFfA(I)  .NE.  LPARI  GO  TO  15 

FRMAT 

39 

NPARsNPAR^l 

FRMAT 

40 

IF (NPAR  .GT.  3)  GO  TO  70 

FRMAT 

41 

GO  TO  20 

FRMAT 

42 

15 

IFIAdl  .NE.  RPAR)  GO  TO  20 

FRMAT 

43 

NPAR:NPAR-1 

FRMAT 

44 

NRP>NRP«1 

FRMAT 

45 

C»»  STORE  lOCATIOtC  Of  RIGHT  PARENS 

FRMAT 

46 

RPLOC  CNRP>»I 

FRMAT 

47 

IF  CNPAR  .LT.  01  GO  TO  70 

FRMAT 

48 

20 

CONTINUE 

FRMAT 

49 

IF (NPAR  .NE.  01  60  TO  70 

FRMAT 

51 

IF(NEXT(RPL0C(NRPM1I  .NE.  BLANKI  60  TO  70 

FRMAT 

51 

00  60  I>ltNRP 

FRMAT 

52 

IGPN0«RPL0C(II 

FRMAT 

53 

00  2S  J«1,N 

FRMAT 

54 

K*IGPN0-J 

FRMAT 

55 

IF(A(KI  .NE.  LPARI  CO  TO  25 

FRMAT 

56 

1 


C»»  GET  CORRESPONDING  LEFT  PAREN  FOR  RIGHT  PAREN 

FRMAT 

57 

IGPST«K 

FRHAT 

58 

GO  TO  30 

FRHAT 

59 

25 

CONTINUC 

FRHAT 

60 

€•♦  CHECK  SYNTAX  OF  GROUP 

FRHAT 

61 

30 

CALL  GROUP 

FRHAT 

62 

IMIGRP  «CQ.  0)  RETURN 

FRHAT 

63 

IF(I  .EQ«  NRP)  GO  TO  65 

FRHAT 

64 

jPTRsIGPST-1 

FRHAT 

65 

31 

CONTINUE 

FRHAT 

66 

IF  (IPREV(JPTR)  .EQ*  2)  GO  TO 

31 

FRHAT 

67 

IGPST*JPTR^2 

FRHAT 

66 

SEPST»IGPNO»l 

FRHAT 

69 

CHECK  NEXT  SEPARATOR 

FRHAT 

70 

OIR-1 

FRHAT 

71 

CALL  SEPAR 

FRHAT 

72 

IF<ISEP  «NE.  1)  GO  TO  40 

FRHAT 

73 

IGPNO*SEPNO 

FRHAT 

74 

GO  TO  50 

FRHAT 

75 

40 

IF (NEXT CSEPST)  .NE.  RPARJ  GO 

TO  70 

FRHAT 

76 

C»»  CHECK  PRECEDING  SEPARATOR 

FRHAT 

77 

SEPST*IGPST-1 

FRHAT 

78 

OIR*-l 

FRHAT 

79 

CALL  SEPAR 

FRHAT 

80 

IFCISEP  .NE.  11  GO  TO  45 

FRHAT 

81 

IGP$T«SEPNO 

FRHAT 

82 

GO  TO  50 

FRHAT 

83 

45 

IF(A(SEPNO>  .NE.  LPAR>  GO  TO 

70 

FRHAT 

84 

50 

00  55  JsIGPST, IGPNO 

FRHAT 

85 

A( J)«eiANK 

FRHAT 

86 

55 

CONTINUE 

FRHAT 

87 

60 

CONTINUE 

FRHAT 

88 

65 

IFRMTsl 

FRHAT 

89 

RETURN 

FRHAT 

90 

ro 

CALL  ERR0RI7I 

FRHAT 

91 

RETURN 

FRHAT 

92 

ENO 

FRHAT 

93 

SU6R0UTINE  GEMROL  GFNROL  2 

COHHON  A (13261  ,0  (500»  t lOTeUStSOO  ) • INITIOO)  *L  ASTIO<  31  • ISRCH  (3)«  RICH  2 

• JPtRtN«H, JTfP,tSTART«N2,IFNCNH,LOGIO,NXTlO, ID TT P , NI 0 • LOC t CTS6A  80 

2 LTYP,ITrP,I0LKOT*MOOE,rePR*IOFS  PICK  % 

COHHON/GLOBAL /NBL  K« NR6F • NSUBS • BLKTBL ( 2 00  ) tFX TT BL ( 1 00 ) t ISUBSI 10  0)  GFNROL  A 

COHHON/LIST/NL 1ST, NINTFC* ISUBLT 12,200) flWTFACt 300)  CENROL  5 

COHHON/INPOUT/NCALL.IN, I OP  GENROL  6 

COHHON/MASTE/IOUH (63)  GENROL  7 

INTEGER  0LKT0L,EXTT8L,eiTGET  GENROL  8 

C**  THIS  routine  is  called  in  the  roll  call  node  to  generate  the  HAIN  CENROL  9 

C**  ROLL  call  PROCRAH  GENROL  10 

write (6,2)  GENROL  11 

2 FORMAT (IHl)  GENROL  12 

C»*  GENERATE  PROGRAM  CARO  GENROL  13 

WRITE(I0P,4)  GENROL  14 

4 FORMAT  I5X,48H  PROGRA M ROLC AL ( OUTPUT, T A PE 6«OU TP  UT  , T APE  3 , TA PE9 , / GENROL  15 

• 5X,44H*  TAPE 10,TAPE11,TAPE12,TAPE13,TAPE14,TAPE15))  GENROL  16 

IE(N0LK  ,EO,  0)  GO  TO  6 GENROL  17 

<s-l  CENROL  18 

C**  THIS  LOOP  GENERATES  COMMON  STATEMENTS  GENROL  19 

00  5 Isl,N0LX  GENROL  20 

GENROL  21 

INOEXsBLX^BLd)  CENROL  22 

ISZ*BITGEf  (ISU0LT  12, 1 NOE  X ) , 3 0 , 15 ) GENROL  23 

MRITE(I0P,3I  ISUBLTd,  INDEX)  ,*C,  IS7  GENROL  24 

3 format  (5X,8H  COMMON/, AS,  3H/IX,  12, IHI,  16,  IHU  GENROL  25 

5 CONTINUE  GENROL  26 

C**  GENERATE  LOOP  TO  DUMMY  OUT  COMMON  BLOCKS  GENROL  27 

6 NRITECI0P,7)  mode  GENROL  28 

7 E0RMAT(5X,4H  J>1/5X,6H  MODE* , 1 1 /5X , 10 H REWIND  13/5X,10H  REWIND  14/  GENROL  29 

S 5X.10H  REWIND  15/5X,13H  00  10  I«1,13/5X,6H  J>>1»  GENROL  30 

IE(NBLK  .EO,  0)  GO  TO  22  GENROL  31 

K=-l  GENROL  32 

DO  20  I>1,NBLK  GENROL  33 

K=K»1  GENROL  34 

KKslOOO^K  GENROL  35 

i*NOEXsBLKTBL(  I ) GENROL  36 

ISZ»BITGET (ISUBLT (2,IN0EXI  ,30, 15)  GENROL  37 

WRITE(IOP,10)  KK,IS7,K,KK  GENROL  38 

10  F0RMAT(5X,4H  DO  ,I4,5H  K»  1 , , 1 6/5X , 3M  I V, 12 , 5 H ( K) « 1/1 X , 14,  GENROL  39 

$ 9H  CONTINUE)  GENROL  40 

IF  (ISUBLT  (1 , INDEX)  ,NE,  6HSESC0M)  GO  TO  20  CENROL  41 

C**  SET  I/O  DEVICES  IN  COMMON  BLOCK  SESCOM  GENROL  42 

WRITE (I0P,15)  K,K,K  GENROL  43 

15  E0RMAT(5X,3H  I X , I 2, 7H ( 17 ) * 10 /5 X , 3H  I X , 12  ,7H ( 20  )« 1 1 / GENROL  44 

• 5X,3M  IX, 12, 7H(23)«12I  GENROL  45 

20  CONTINUE  GENROL  46 

C»*  GENERATE  CALL  TO  THE  MODULE  ANO  DUMMY  ARGUWNT  L HT  - MODULE  GENROL  47 

C**  CONTAINS  CALLS  TO  -ROLCHW  GENROL  48 

22  NARC=BITGET(I0TBL (3,1) ,7,6)  GENROL  49 

DO  30  I*1,NARG  GENROL  51 

1E(I  .EQ,  NARG)  GO  TO  25  CENROL  51 

IOUM(I)*2HO,  GENROL  52 

GO  TO  30  CENROL  53 

25  I0UM(I)*2HJ)  GENROL  54 

30  CONTINUE  GENROL  55 

WRITE(I0P,35)  (IOTBL (1 ,1 ) « (I0UH( I) , !■! ,NARG) ) GENROL  56 

35  E0PMAT(5X,6M  CALL  , A6 • 1 H ( , 41 A2/5X , 1 H l , IX ,22  A 2)  GENROL  57 

C**  GENERATE  REMAINDER  OF  PROGRAM  INCLUDING  CALLS  TO  ROLL  CALL  GENROL  58 

C**  auxiliary  programs  -MOOIO*  AMO  “COMPARE"  GENROL  59 

WR ITE  ( IOP,40)  GENROL  60 

40  FORMAT  (5X,23H  IE(M00E  .EQ.  3IGO  TO  5/5X,14h  CALL  MOOIO(J)/  GENROL  61 

I 3X,12H  5 ENOFILF  3/2x,12H  10  CONTINUE /5 X, 12H  CALL  CMPARE/  GENROL  62 

t 5X,9H  REWIND  3/5X,10H  REWIND  13/5X,10H  REWIND  14/5X,10M  REWIND  15  GENROL  63 

S /5X.5M  ST0P/5X,4H  END)  GENROL  64 

RETURN  GENROL  65 

END  GENROL  66 


h() 


subroutine  GLOTie 

COHNON  AC13e6ltO(500)»IOTeL(8,SOO).INITIO(3)«L«STIOf3)» ISRCHC3  >• 

• JPTR*N,M,JTfP,LSTAPT,N?, IFNCNH*L0GI0,NXTID* 10  rYP,NIO*LOC* 

2 LTYP* ITYP,IBLKOT,HOOE*IERR.IOES 

C0NN0N/GL09lL/N8LRtNREF, MSUBS * 8L XTBL I ?00  J.EXTT  Bt  f 100 ) • ISUBS f 10 0 ) 
C0MH0N/LIST/NLIST,NINTFC, ISU0LT (^,^O0 ) •INTFACI 3001 
INTEGER  8ITGET  .BUCTBL  fEXTTBL  *<L  AS  C3,7) 

DATA  KLAS/IONUSER  SUPPL * 3MIEO* I OHSUBROUT INE • 7H  MODULE* 

• iOHFUNCTION  M*6HOOULE*<IHANCILLARY,lOHSUePROGRAM,10HAN$I  FUNCT  , 

• 3HION,10HHAIN  PROGR , 2HA M* 10 HE XTRAORD I N,  10 HA RY  SUBPR*/ 

this  routine  displays  the  global  reference  table 

WRITE (6*  U 

1 F0RNATUHl*4aX,23H  GLOBAL  REFERENCE  TABLEl 
IFCNREF  ,EO.  01  GO  TO  25 

C**  DISPLAY  EXTERNAL  REFERENCES 
WRITE  C6,2I 

2 FORMAT (//50X,  20M  EXTERNAL  REFERENCES! 

DO  20  I»1,NR£F 

C**  GET  SESCOMP  LIST  LOCATION 
IN0EX«EXTT8L(I ) 

C**  SET  SUBPROGRAM  CLASS 

J«BITGET (ISUBLT (2,INDEX1 , 10*  4! 

WRITE  (6*  10)  ISUBLTfl*INOEX),KLAS(l«  J^l)  * tq.AS  (2  «J»1) 
to  FORMAT f45X*A6« 4X, 2A10) 

20  continue 

29  IFfNBLX  .EQ*  0 •OR*  TNBLK  .EQ*  1 .AND*  I SUBLT  ( 1*  BLICTSL  <1 ! ! .EO« 
t IH  M GO  TO  40 

€•*  DISPLAY  LABELLED  COMMON  BLOCKS 
WRITE<6*30I 

30  FORMAT (//49X, 23H  LABELLED  COMMON  6L OC KS/ 43X « 11 H BLOCK  NAME*7X« 

$ 5H  SI2E*7X*6H  CLASS) 

00  36  J«l*NBLK 

C**  GET  SESCOMP  LIST  LOCATION 
INOEX*PLKTBLf J) 

C**  GET  COMMON  BLXK  CATEGORY 

ICAT*BITGET (ISUBLT <2, INDEX) , 10*4) -6 
ISZ*0ITGETIISUBlT(2, INDEX) *30*15) 

35  FORMAT (46X,A6*5X*I8*5X,RHCATEG0RY  *12) 

WRITE (6*  35)  ISUBLT (1*1  NOE  X), IS  7* ICAT 
38  CONTINUE 

C**  DISPLAY  SUBROUTI^CS 
40  WRITE(b*45) 

45  FORMAT  (///46X  * 24H  SUBROUTINES  ENCOUNTERED) 

DO  60  I>1*NSUBS 
C**  GET  SUBROUTINE  CLASS 
INOEX«ISUBS(I) 

J>6ITGET ( ISUBLT (2, INDEX) *10*4) 

WRITE (6* 10)  ISUBLT (1* INDEX) *KLAS(1* J»1 )*  KLAS  (2  * J«l) 

60  CONTINUE 

return 

END 


GLOTAB 

RICH 

CY5  6A 

RICH 

GLOTAB 

GLOTAB 

GLOTAB 

GLOTAB 

GLOTAB 

GLOTAB 

GLOTAB 

GLOTAB 

GLOTAB 

GLOTAB 

GLOTAB 

GLOTAB 

GLOTAB 

GLOTAB 

GLOTAB 

GLOTAB 

GLOTAB 

GLOTAB 

GLOTAB 

GLOTAB 

GLOTAB 

GLOTAB 

GLOTAB 

GLO  TAB 

GLOTAB 

GLOTAB 

GLOTAB 

GLOTAB 

GLOTAB 

GLOTAB 

GLOTAB 

GLOTAB 

GLOTAB 

GLOTAB 

GLOTAB 

GLOTAB 

GLOTAB 

GLOTAB 

GLOTAB 

GLOTAB 

GLOTAB 

GLOTAB 

GLOTAB 

GLOTAB 

GLOTAB 

GLOTAB 

GLOTAB 


SUBROUT  I Nf  GNLE 

COHHON  A ilZ2f>)  ,OCSOQI,IOTBLC«,SOO),INITIO(3>,LASTIO(3I  ,I$RCH(3  )• 
• JPTR, N, M,JTYP ,L start, N? , TFNCNH , L OGIO , NX T 10, 10  TY  P,NIO, LOC , 

2 LTYP,  ITYP,I3LK0T,M00E ,IERR, lOFS 
COMHON/LOGIC/L  OG.LOGST 
COHHON/REACNO/ IREAt, IRtL  NO, TP 

INTEGER  A,0,9L ANX,PLUS,EQUALS,SLASH,RPAR ,C0MHA ,ASTPIK, 

1 AICH.OECPT 

OATA  BLANK/IH  /, PLUS/1 /, MI NUS/ 1 H-/, EQU ALS/ IH s/ , SL ASH/IH //, 

1 ppAR/iMi /,comha/ih,/,astrix/ih*/,aich/i HH/ , LP AR / 1 M( / , OECPT/ IH , / 
THIS  routine  scans  THE  INPUT  STRING  STARTING  AT  -JPTR"  A NO  RETURNS 
THE  NEXT  language  ELEHENT 
JTYPsQ  - BLANK 

ARITHMETIC  OPERATOR 
NAME 

HOLLERITH  string 
REAL  NUMBER 
INTEGER 

COMPLEX  number 
logical  OPERATOR  OR  CONSTANT 
INVALID 


JTYP=1 
JTYP=? 

JTYP=3 
JirP‘k 
JTYP=S 
JTYP*6 
JTYP=7 
JTYP=8 
JTVP=0 

NXT*NEXT ( JPTR) 

IFINXT  .EQ.  BLANK!  RETURN 

LSTART*JPTR-1 

lEINXT  .EO.  PLUS!  GO  TO  1 

IF(NXT  .EQ.  RPAR!  GO  TO  1 

IFINXT  .EO.  MINUS!  GO  TO  1 

IFINXT  .EQ.  SLASH)  GO  TO  1 

IFINXT  .EO.  COMMA!  GO  TO  1 

IFINXT  .EO.  EQUALS!  GO  TO  1 

GO  TO  2 

JTYPsl 

M^  1 

GO  TO  BO 

IFINXT  .NE.  ASTRIK)  GO  TO  4 


.NE.  ASTRIK!  GO  TO  I 


10 


IF  INEXT IJPTR) 

M=2 

JTYP*1 
GO  TO  90 

IFINXT  .NE.  LPAR)  GO  TO  40 
IFILSTART  .EO.  I!  GO  TO  10 
IM1»LSTART-1 

IF  ITPREVIIMI!  .NE.  3!  GO  TO  1 
CONTINUE 

NXT^NEXT ILSTART^I ! 

IFINXT  .EQ.  BLANK)  GO  TO  120 
IFINXT  .NE.  PLUS  .AND.  NXT  . NE . 

IP*JPTR 
GO  TO  ?4 
TPsJPTR-l 
CALL  REAlCK 

IFIIREAL  .EQ.  0!  GO  TO  1 
IF  HOES  .EQ.  1 ! GO  TO  1 
IF  INE XT  I IRELNO ♦! ! .NE.  COMMA! 

NXTsNEXTIJPTR) 

IFI  NXT  .NE.  PLUS  .AND.  NXT  .NE.  MINUS)  GO  TO  30 


MINUS)  GO  TO  22 


GO  TO  1 


GNLE 

RICH 

CY58A 

RICH 

GNLE 

GNLE 

GNLE 

GNLE 

GNLE 

GNLE 

GNLE 

GNLE 

GNLE 

GNLE 

GNLE 

GNLE 

GNLE 

GNLE 

GNLE 

GNLE 

GNLE 

GNLE 

GNLE 

GNLE 

GNLE 

GNLE 

GNLE 

GNLE 

GNLE 

GNLE 

GNLE 

GNLE 

GNLE 

GNLE 

GNLE 

GNLE 

GNLE 

GNLE 

GNLE 

GNLE 

GNLE 

GNLE 

GNLE 

GNLE 

GNLE 

GNLE 

GNLE 

GNLE 

GNLE 

GNLE 

GNLE 

GNLE 

GNLE 

GNLE 

GNLE 


1 


IP*JPTR 

gnle 

57 

GO  TO  35 

gnle 

50 

30 

IP*JPTP-1 

gnle 

59 

35 

CALL  R6ALCK 

gnle 

60 

IFCIREAL  «EQ.  0)  CO  TO  120 

GNLE 

61 

IF  Cioes  •EQ,  1 ) GO  TO  120 

gnle 

62 

IF(NEXT<IRELNO»l)  *NE«  RPAR)  GO  TO  120 

gnle 

63 

JTYP*6 

gnle 

64 

jptr-lstart 

GNLE 

65 

GO  TO  SO 

gnle 

66 

iiO 

IFCNKT  *NE.  OECPT»  GO  TO  50 

GNLE 

67 

ITP*ITYPEUPTRI 

gnle 

60 

IF(ITP-2)  42*44,  120 

gnle 

69 

LOGSTaLSTART^l 

gnle 

70 

CALL  LOGCHK 

GNLE 

71 

IFILOG  .EQ.  0>  go  TO  129 

gnle 

72 

JTYP«7 

gnle 

73 

K=  JPTR-LSTART 

gnle 

74 

GO  TO  SO 

gnle 

75 

l»4 

IP=LSTART 

gnle 

76 

CALL  REALCS 

gnle 

77 

IFCIREAL  .EQ.  0)  GO  TO  120 

gnle 

70 

JTYP*4 

GNLE 

79 

H=  IRELNO-LSTART*! 

gnle 

00 

GO  TO  SO 

gnle 

01 

SO 

CONTINUE 

gnle 

02 

IF CITYPE  ILSTARTI  ,NE*  2)  GO  TO  05 

gnle 

03 

IF  IITYP  .EQ.  201  GO  TO  54 

gnle 

04 

IP«LSTART 

gnle 

05 

call  realcs 

gnle 

06 

IF  (IREAL  .EQ.  0)  GO  TO  54 

GNLE 

07 

JTYP  = 4 

gnle 

00 

N*  irelno-lstart^i 

gnle 

09 

GO  TO  SO 

gnle 

SO 

54 

jptr=lstart»i 

gnle 

SI 

55 

IFfITYPEUPTRI  .EQ.  2)  GO  TO  57 

gnle 

92 

GO  TO  65 

gnle 

S3 

S 7 

IFCJPTR  .GT.  Nl  GO  TO  60 

gnle 

94 

GO  TO  55 

gnle 

95 

60 

h=n-lstart»i 

gnle 

96 

JTYP*5 

gnl  e 

97 

GO  TO  SO 

gnle 

90 

65 

IF(AUPTR-1J  .me.  AICH»  go  to  67 

gnle 

99 

IFdTYP  .EQ.  0 .OR.  ITYP  .EQ.  20  .OR.  IT  YP  , EQ . 27»  CO  TO  70 

gnle 

100 

67 

m*jptr-lstart-i 

gnle 

101 

JTYPsS 

gnle 

10? 

GO  TO  SO 

gnle 

103 

70 

IFfJPTR  .GT.  Nl  GO  TO  120 

gnle 

104 

K*N-LSTART»1 

gnle 

105 

IF  .GT.  5001  M*500 

GNLE 

106 

JTYP«3 

gnle 

107 

GO  TO  SO 

gnle 

lOO 

05 

CONTINUE 

gnle 

109 

IF  IITYPE  CLSTART)  .NE.  1)  GO  TO  120 

gnle 

110 

IFfITYP  .EQ.  201  GO  TO  100 

gnle 

111 

00 

CONTINUE 

gnle 

112 

IF  fITYPE  UPTRI  .NE.  31  GO  TO  06 

gnle 

113 

: 


JPTR-LSTART -1 

gnle 

lib 

jjyp'Z 

gnle 

118 

GO  TO  90 

gnle 

116 

Sb  IF  JJPTR  .GT.  Nl  GO  TO  8T 

gnle 

iir 

GO  TO  6S 

gnle 

118 

100  K=1 

gnle 

119 

JTTP*2 

gnle 

1?0 

GO  TO  90 

gnle 

XZi 

8T  K=N-LSTART^1 

gnle 

122 

jTYPs? 

gnle 

129 

90  CONTlMU€ 

gnle 

12b 

€••  STORE  THE  NEXT  ELEMENT  IN  "0~ 

gnle 

128 

C**  SQUEEZE  BLANKS  OUT  OF  STRING 

gnle 

126 

00  91  L«1*H 

gnle 

12T 

LL*LST»RTtL-l 

gnle 

128 

0(U>AaU 

gnle 

129 

91  CONTINUE 

gnle 

190 

JPTR*LST»RT  fM 

gnle 

131 

CALL  SQUEEZ 

gnle 

192 

C**  PROCESS  THE  ELEMENT 

gnle 

139 

CALL  FORHEL 

gnle 

13b 

RETURN 

GNLE 

198 

1?0  CONTINUE 

gnle 

136 

JTYP*  0 

gnle 

137 

RETURN 

gnle 

196 

ENO 

gnle 

139 

SUBROUTINE  GOTO 

GOTO 

2 

COMMON  Aa326),O<5OO»fIOT0L(8t8OO»,INITIO(T),LASTIO(3) 

, ISRCH(3  )• 

RICH 

2 

• JPTR,N,M,JTYP ,LSTART ,N2, IFNC NM , L OGI 0 * W T 1 0,  10 TY P, NI  0 , 

LOC, 

CY58A 

80 

2 LTYP, ITYP, IBLKOT ,MOOE ,IERR, lOFS 

RICH 

4 

COMHON/L ABELS/ STA  TRA 1 2« 2 00 > , NL ABE L 

GOTO 

4 

COMHON/BASBL</IBLOCK(2800 ) , NBL OCK , NB • NBR NCh 

CYS8A 

?r 

DIMENSION  lALPHfbl 

GOTO 

6 

INTEGER  STATRA, BLANK 

GOTO 

7 

INTEGER  BITPJT 

GOTO 

8 

DATA  UALPHfll  ,Icl,bl/lHG,lHO,lHT,lHO/ 

GOTO 

9 

DATA  0LANK/1H  / 

GOTO 

10 

C*» 

-GO  TO-  STATEMENT  PROCESSOR 

GOTO 

11 

00  8 1*1,4 

GOTO 

12 

IF  INEXT  ( JPTRI  ,NE.  lALPMflM  GO  TO  10 

GOTO 

19 

5 continue 

GOTO 

14 

C** 

GET  statement  label 

GOTO 

18 

CALL  gnle 

GOTO 

16 

IF  IJTYP  ,NE.  81  GO  TO  10 

GOTO 

17 

C*» 

SEARCH  statement  number  TAPIF  ANO  SET  “GO  To-  FLAG 

GOTO 

18 

CALL  STSRCH 

GOTO 

19 

ST ATRA  C2,LOC>  *BI TPUTISTATRAI2,L0C>  *1 1 1 ?) 

GOTO 

20 

IFINEXTIJPTRI  ,NE.  BLANK»  GO  TO 

GOTO 

21 

STORE  BRANCH  IN  BASIC  BLOCK  TABL^ 

GOTO 

22 

NBLOCK*NBLOC»<F  1 

GOTO 

23 

IBLOCK <NBLOC<  1 «LOC 

GOTO 

?b 

NBRNCHsl 

GOTO 

28 

NB*1 

GOTO 

26 

RE  TURN 

GOTO 

27 

10  CALL  ERRORtT) 

GOT  0 

20 

PE  TURN 

GOTO 

29 

ENO 

GOTO 

TO 

SUBROUTINE  GROUR 

GROUP 

3 

COMMON  *(13261  ,0(600l,IOTei(8,<;oat,INITIO(3t,L  *STIO(3l  ,ISRCH(3t. 

RICH 

3 

• JPTR.N.M, JTTP.LSTART.N?, IFNCHM.LOCID 

• NKTIO,  IOTYP.NIO.LOC. 

CTSOA 

SI 

2 1 TTP, ITTP, IBL  HOT , MODE , lEPR, lOES 

RICH 

H 

COMNON/FORHAr/IOESST*IOESNO«IGPSr«IGPNO« 

IGRP.SEPST.SEPNO. 

CY50A 

J 

1 OIR.ICOM.ISEP 

GROUP 

9 

INTEGER  »,RP*R,SEPST,SEPNO,OIR 

GROUP 

6 

0«T«  RPAR/IH)/ 

GROUP 

7 

IF  (NE*T(IGPST»H  .EO.  RP»Rt  GO  TO  20 

GROUP 

I 

THIS  ROUTINE  CHECKS  THE  SYNTA*  OP  A GROUP 

OF  field  descriptors 

GROUP 

9 

C**  AND  RETURNS  IGRP«1  - VALID 

GROUP 

10 

C**  IGRP»0  - INVALID 

GROUP 

11 

SEPST«JRTR-1 

GROUP 

13 

0IR>1 

GROUP 

13 

CALL  SCRAP 

GROUP 

Ih 

€••  CHECK  INITIAL  SEPARATOR 

GROUP 

15 

IMISER  «EQ«  -1  .OR.  ICON  .EQ.  11  GO 

TO 

38 

GROUP 

16 

IFilSEP  .EQ.  0)  IOESST»SERST 

GROUP 

17 

IFUSEP  .EQ.  11  IOESST*SEP>0^1 

GROUP 

19 

IF (NEIT (lOESST I .EQ.  RPARt  GO  TO  ?0 

GROUP 

19 

C**  CHECK  FINAL  SEPARATOR 

GROUP 

31 

SEPST«IGRNO-l 

GROIP 

31 

OIR*-l 

GROUP 

33 

CALL  SCRAP 

GROUP 

33 

IFIISER  .EQ.  -1  .OR.  ICON  .EQ.  1)  GO 

TO 

30 

GROUP 

36 

0IR«1 

GROUP 

35 

10  CONTINUE 

GROUP 

36 

C**  CHECK  NEKT  DESCRIPTOR 

GROUP 

37 

CALL  OCSCPP 

GROUP 

3S 

IFflOES  .EQ.  1)  GO  TO  M 

GROUP 

39 

SEPST*I0CSNO^l 

GROUP 

30 

IFINEXTCSEPSTI  .EQ.  PRARI  GO  TO  30 

GROUP 

31 

C»*  CHECK  next  separator 

GROUP 

33 

CALL  SCRAP 

GROUP 

33 

IFIISCP  .EQ.  1 .OR.  ISCP  .EQ.  -11  GO 

TO 

38 

GROUP 

36 

I0ESST*SEPN0^1 

GROUP 

35 

IF  INEXT IIOESST 1 .NE.  RPAR)  GO  TO  10 

GROUP 

36 

?0  IGRP*1 

GROUP 

37 

RETURN 

GROUP 

31 

SO  IGPP«0 

GROUP 

39 

CALL  ERROPCr) 

GROUP 

69 

RETURN 

GROUP 

61 

CALL  CPRORIOOf IOESST» 

GROUP 

63 

IGRP«0 

GROUP 

63 

return 

GROUP 

66 

END 

GROUP 

65 

SUBROUTINE  CRT 

COHHON  k(1326) •OISOOl.lOTBLIBtSOOl •1NITI0(3) «L  AST  10 ( 3 > * ISRCH ( 3 ) , 
• JPTRtN,N,jTVP,LSTARTfN3« IFNCNH, LOGIO* MX TIO. 10 TYP,NIO, LOC t 
2 LTYP, ITYP,IBLK0T*M00E*IERR, ioes 
C0HN0N/GL0BAL/NBLX«NREF,NSUBS *81X301  C^00  UEXTTBL  llOQIflSUBSClOQI 
COHHON/LIST/NL IST*NINTFC  * 1SU6LT (2,?0  0>*INTFAC(3IO) 

INTEGER  EXTTBL .BLXTBL*BLANK,0ITPUT,BITGET 
DATA  0LANK/1H  / 

C**  THIS  ROUTINE  IS  CALLED  AFTER  HOOULE  PROCESSING  IS  COMPLETE*  TO 
C**  MAKE  ENTRIES  INTO  THE  GLOBAL  REFERENCE  TABLE 
MRITE  <6* II 
1 FORMATI//I 

C**  START  WITH  FIRST  SUBPROGRAM  NAME 
ISUBsINITIOf?! 

IFflSUB  .EO.  01  GO  TO  15 
C»*  GET  NEXT  SUBPROGRAM  NAME 
10  ISUBsIOTBL <E* ISUBI 

IFIISUB  .EQ*  0)  GO  TO  15 
C**  SKIP  IF  STATEMENT  FUNCTION 

IF(BITGET(I0T6L(3*ISUB)*19*1)  .EQ.  II  GO  TO  10 
IFCNREF  *CQ*  01  GO  TO  4 

C**  SEARCH  EXTERNAL  REFERENCE  TABLE  TO  SEE  IF  NAME  ALREADY  STORED 
DO  3 K»1*NREF 
INOEX*EXTTBL<KI 

IF(I0TBLC1*ISUBI  .EQ.  ISUBLT  f 1 , INDEX)  I 60  TO  10 

3 CONTINUE 

C*^  NAME  NOT  YET  STORED  - INCREMENT  EXTERNAL  REFERENCE  COUNTER 

4 NREFzNREFtl 

IffNREF  *GT*  100)  GO  TO  50 

C**  STORE  SESCOMP  LIST  LOCATION  OF  NAME  IN  EXTERNAL  REFERENCE  TABLE 
EXTTBL  «NREF)  = BITGETaOTBL  (3*  I SUB)  ,36*9) 

IFCMOOE  .EQ*  II  GO  TO  10 
C^*  ROLL  CALL  MODE  - CHECK  SUBPROGRAM  CLASS 

KLAS=BITGETCISUBLTC?*EXTT8LINREFI  ) *10*4) 

C**  IF  SESCOMP  HOOULE  - MRITE  NA)€  ON  AUXILIARY  FILE  FOR  FURTHER  USE 
IFIKLAS  .EQ*  1 .OR*  KLAS  *EQ.  ?l  MRITE<9)  ID TB L ( 1 t ISUB I 
GO  TO  10 

C**  GET  FIRST  COMMON  BLOCK  NAME 
15  IBLK*INITI0(3) 

^0  IFIIRLK  .EQ*  0)  RETURN 

IF  (IDT6L  f 1*IBL  Kl  *EQ.  IH  I CO  TO  45 
C**  SEARCH  symbol  TABLE  FOR  NAME 
DO  ^5  I*1*NLIST 

IFIIOTBL (1*IBLK)  .NE.  lSUeLT(l«III  GO  TO  25 
C**  NAME  FOUND  IN  STMBOL  TABLE 
LISTLC*! 

IFI0ITGET(ISUBLT<2*II*1O«4)  .EQ*  71  60  TO  30 
TF(BITGETnSUBLT(2*I)*30*15l  .NE.  0)  GO  TO  30 
C**  NOT  CATEGORY  1 COMMON  BLOCK  - GET  SITE  AMO  STORE 
IS2*IOT0LI4*IBLKI 

ISUBLT (2*1) *eiTPUT( ISUBLT 12*11  * IS 2* 30) 

GO  TO  30 
2 5 CONTINUE 

C**  COMMON  BLOCK  NOT  FOUND  IN  SESCOMP  LIST  - IF  NOT  BLANK  COMMON* 

C**  ISSUE  DIAGNOSTIC 

call  ERR0R(62*  IDTBL  (1*I6LK)I 
C**  store  COMMON  BLOCK  NAME  IN  SESCOMP  LIST 


6RT 

2 

RICH 

2 

CY58A 

80 

RICH 

4 

6RT 

4 

6RT 

5 

CRT 

6 

GRT 

7 

6RT 

6 

GRT 

9 

GRT 

10 

GRT 

11 

GRT 

12 

GRT 

13 

CRT 

14 

CRT 

15 

GRT 

16 

GRT 

17 

GRT 

IS 

GRT 

19 

GRT 

20 

GRT 

21 

GRT 

22 

CRT 

23 

GRT 

24 

GRT 

25 

CRT 

26 

GRT 

27 

GRT 

28 

CRT 

29 

GRT 

30 

GRT 

31 

GRT 

32 

GRT 

33 

GRT 

34 

GRT 

35 

GRT 

36 

GRT 

37 

GRT 

36 

CRT 

39 

GRT 

40 

CRT 

41 

GRT 

42 

CRT 

43 

GRT 

44 

GRT 

45 

CRT 

46 

GRT 

47 

GRT 

48 

GRT 

49 

GRT 

50 

GRT 

51 

GRT 

52 

GPT 

53 

GRT 

54 

GRT 

55 

GRT 

56 

nlist»nlist*i 

ISU8LT  (l,NLISn»IOTBL(lt  IBLK) 

C*»  STORf  COMMON  BLOCK  SIZE  IN  SESCOHP  LIST 
ISZ=IOTBL  (<«,IBLK) 

ISOBLT  (2.NLIST  l«SHIFT  (ISZflO  ( .OR.  SHIFT  110,501 
LISTlC=NLIST 

C»»  STORf  LIST  LOCOTIOM  IN  SYMBOL  T»BLE 

3 0 I0T8L  (3,I8LK1  *8ITPOTIIOTBL  13 , 1"L  K 1 , 1 1 STL  C,  36 1 
IF  (NBLK  .EQ.  0 1 GO  TO  <«0 
C**  SEORCH  COMMON  BLOCK  LIST  FOR  NAM^ 

DO  35  K«1,N8lK 

IFILISTLC  .EQ.  BLKTBL«K)1  CO  TO  45 
35  CONTINUE 

C»*  NAME  NOT  FOUND  IN  COMMON  BLOCK  LIST 
C*»  INCREMENT  COMMON  BLOCK  COUNTER  AND  STORE  IN  LIST 
40  NBLK=NBLK*1 

IFINBLK  .GT.  ZOO)  GO  TO  60 
8LKT8L  (N8LK)  = L ISTLC 
45  IBLK=IDT8L  (Z.IBLK) 

GO  TO  ZO 

50  CALL  ERROR(5B) 

STOP 

60  CALL  ERROR(60  1 
STOP 
END 
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57 

GRT 

58 

GPT 

59 

GRT 

60 

GRT 

61 

GRT 

6Z 

GRT 
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GRT 

64 

GRT 

65 

GRT 

66 

CRT 

67 

GRT 

68 

GRT 

69 

GRT 

70 

GRT 

71 

CRT 

7Z 

GRT 

73 

GRT 

74 

GRT 

75 

CRT 

76 

GRT 

77 

GRT 

78 

GRT 

79 

GRT 
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81 

SUBROUTINE  IMPTYP  IMPTYP 

COMMON  A)13Z6),0(500>.IOTBLI8,500),INITIO<3),LASTIom  ,ISRCM(3),  RICH 
• JPTR,  N,  M.JTYP.LS  tart,  NZ,  IFNCNM.LOG  10,  NX  TIO,  ID  TY  P,  NIO  , LOC  , CY5  8A 

z ltyp,  ityp,iblkot,mooe,ierr,ioes  rich 

DIMENSION  IALPH(6)  IMPTYP 

INTEGER  0,BITPUT,BITGET  IMPTYP 

DATA  IIALPH(I)  , I»1,6)/1HI,1HJ,  IHK.IHL  , IHM.IHN/  IMPTYP 

C»»  THIS  ROUTINE  CHECKS  THAT  THE  VARIABLE  TYPE  HAS  BEEN  SET  IMPTYP 

C»*  IF  NOT,  THE  TYPE  IS  SET  IMPLICITLY  IMPTYP 

IF  (BITGET«I0TBL«3, LOC)  ,11,11  .EO.  1)  GO  TO  ZO  IMPTYP 

C»*  TYPE  NOT  yet  set,  SET  "TYPE  SET"  FLAG  IMPTYP 

lOTBL  «3,L0C)  = 8ITPUT«I0TBL  I3,L0C)  ,1,11)  IMPTYP 

no  10  I»l,6  IMPTYP 

IF«0«1)  .NE.  lALPHJI))  GO  TO  10  IMPTYP 

C»»  VARIABLE  BEGINS  MITH  I,J,K,L,M,  OR  N - SET  TYPE  TO  INTEGER  IMPTYP 

IOTBL«3,LOC)  = BITPUTCIOTBL(3,LOC)  ,4,10)  IMPTYP 

GO  TO  ZO  IMPTYP 

10  CONTINUE  IMPTYP 

C»*  VARIABLE  DOES  NOT  BEGIN  NITH  I,J,K,L,M,  OR  N - SET  TYPE  TO  REAL  IMPTYP 

IOT8L  ( 3,LOC)  = 8ITPUT«  IOTBL  «3,L0C)  ,1,10  ) IMPTYP 

C*»  IF  EXECUTABLE  STATEMENT,  SET  FLAG  IMPTYP 

ZO  IFIITYP  ,LE.  18)  I0T8L  (3,LQC)*BI  TPUT)  lOT  BL  t3  ,L  OC)  ,1,38)  IMPTYP 

RETURN  IMPTYP 

ENO  IMPTYP 
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subroutine  init 

INIT 

2 

COHHON  A(13?6I  ,D(S00>tIDTBLIR«S00 It  INITIO! 31 tL tSTIOl 3 1 t ISRCH (3 1 , 

RICH 

2 

• JPTRtN.M, JTTP.L START, N2, IFNCMN, LOCI Ot NX TIOt 10  TYP.NIO, LOC , 

CY58A 

80 

Z LTYP,  ITYP,I9LKOT,MOOE,IERR,  IOES 

RICP 

4 

C0MM0N/FUNC/IFNCRA!5,1ZI  .MARCS,  I ARCS  C 5 01  .FNCLOCISI  ,NFUNC 

CY58A 

r 

COHMOM/STRIN3/NTYPE,NSTR,STR!SOO) 

INIT 

5 

COMMON/T  YP/MQO  ,RHSTYP,NQ3,NQ3,LHSTYP 

INIT 

6 

COMMON/L  1ST /NL  1ST, N INT FC,  ISUBLT  (2,2001  .INTFAC!  3001 

INI  T 

7 

COHHON/eASBLX/t8LOCK(2SOOI  ,NBL  OCX  ,NB  , NBR  NCH 

CY58A 

8 

COMHON/STFUNC/NSTFNC.ISTFNC!  10) 

INIT 

9 

INTECER  RHSTYP 

INIT 

10 

INTECER  A, EQUALS, COMMA, RPAR.STR 

INIT 

11 

INTECER  RITPUT.BITGET.FNCLX 

INIT 

12 

OATA  EQUALS/1M*/,LPAR/1H(/,C0MMA/1H,/,RP  AR/IH)  / 

INI  T 

13 

ASSIGNMENT  STATEMENT  PROCESSOR 

INIT 

14 

ifn«o 

INIT 

15 

NTYPE»1 

INIT 

16 

IPTR»JPTR 

INIT 

17 

C*»  GET  ASSIGNEO  VARIABLE 

INIT 

18 

CALL  GNLE 

INIT 

19 

IFCJTYP  .NE.  2)  GO  TO  40 

INIT 

20 

call  search 

INI  T 

21 

IFINEXT(JPTR)  .NE.  EQUALS)  GO  TO  6 

INIT 

22 

C»»  ASSIGNEO  VARIABLE  IS  NOT  OIMENSIONEO 

INIT 

23 

LOC2=0 

INIT 

24 

IF (ISRCH(2I  .NE.  1)  GO  TO  2 

INIT 

25 

C**  VARIABLE  IS  A FUNCTION,  MUST  BE  THE  FUNCTION  NAME 

INIT 

26 

IFINXTIO  .NE.  IFNCNMI  CA  LL  ERROR!  10  , NXTI  01 

INIT 

27 

IFN=1 

INIT 

28 

C»»  SET  TYPE 

INIT 

29 

CALL  IMPTYP 

INIT 

30 

LOC2»LX 

INIT 

31 

2 IF!ISRCH!1)  .NE.  11  GO  TO  18 

INIT 

32 

IF  !LX2  .EQ.  01  GO  TO  4 

INIT 

33 

LOC»IOES 

INIT 

34 

GO  TO  5 

INIT 

35 

C»»  STORE  IN  SYMBa  TABLE 

INIT 

36 

18  IOTYP«l 

INIT 

37 

CALL  STORE 

INIT 

38 

LOC*NIO 

INIT 

39 

IF!L0C2  .EQ.  01  GO  TO  4 

INIT 

40 

lOTBL  !3,LOC)«IOTBL!3,LOC2) 

INIT 

41 

CO  TO  5 

INIT 

42 

C»»  SET  TYPE 

INIT 

43 

4 CALL  IMPTYP 

.NIT 

44 

C»»  SET  “left  SIOE  TYPE"  TO  VARIABLE  TYPE 

INI  T 

45 

5 LHSTYPsBITGET  !IOTBL!3,LOCI,lO,3) 

INI  T 

46 

IF!LHSTYP  .EQ.  51  NTYPE*2 

INIT 

47 

GO  TO  30 

INI  T 

46 

6 IF!A!JPTR-1I  .ME.  LPAR)  GO  TO  40 

INIT 

49 

IF!ISRCH!1I  .EQ.  11  GO  TO  12 

INIT 

50 

IF!ISRCH!2)  .me.  1)  GO  TO  15 

INIT 

51 

call  ERRORdO  , NX  TIO) 

INIT 

52 

CO  TO  8 

INIT 

53 

C»*  FUNCTION  OEFINING  STATEMENT 

INIT 

54 

C»»  STORE  VARIABLE  AS  FUNCTION 

INIT 

55 

15  IOTYP.2 

INI  T 

56 

'.s 


CALL  STORE 

INIT 

57 

LOCsNIO 

INIT 

50 

GO  TO  6 

INI  T 

59 

7 CALL  SWITCH 

INIT 

60 

C**  SET  TYPE 

INI  T 

61 

» CALL  IHPTYP 

INIT 

62 

LHSTYP«BITGET ( IOTBL (3«L0C) «1Q« 1) 

INIT 

63 

IFILHSTYP  ,£0.  5)  NTYP£»? 

INIT 

66 

NA RG=0 

INI  T 

65 

rTYP*35 

INIT 

66 

C*»  STORE  IN  STATEMENT  FUNCTION  TABLE 

INIT 

67 

NSTFNC»NSTFNC ♦! 

INIT 

60 

IFCNSTFNC  «GT«  10)  GO  TO  60 

CY5SA 

9 

ISTFNC  CMSTFNC) «LOC 

INIT 

69 

LOCl  = LOC 

INIT 

70 

C**  SET  “STATEMENT  FUNCTION"  FLAG 

INIT 

71 

IOTBL  f 3tLOC)*BlTPUTaOT0L  f 3,LOC)  ti,  191 

INIT 

72 

GET  ARGUMENT 

INIT 

73 

10  CALL  GNLE 

INIT 

76 

IFIJTYP  .NE.  21  GO  TO  60 

INIT 

75 

C**  STORE  ARGUMENT  IN  SYHBOL  TABLE 

INI  T 

76 

NARGsNARG^l 

INIT 

77 

CALL  SEARCH 

INIT 

78 

IF<ISRCH(2)  .EQ«  It  CAU  E RROR < 66 ,NARG t 

INI  T 

79 

IFdSRCHd)  .EQ.  1)  GO  TO  20 

INI  T 

00 

IOTYP*l 

INI  T 

01 

CALL  STORE 

INIT 

82 

LOC*NIO 

INIT 

83 

GO  TO  25 

INIT 

04 

20  IF  (8ITGET  aOTBL  (3«LOCI  It  •EO*  U CALL  ERROR  <66, HARGt 

INIT 

66 

26  CALL  IHPTYP 

INI  T 

86 

IF(NrvTIJPTR)  .EO,  COMMA)  GO  TO  10 

INIT 

67 

IFUlJPTR-1)  .NE*  RPAR)  GO  TO  40 

INI  T 

80 

C**  STORE  NO.  OF  ARGUMENTS  IN  SYMBOL  TABLE 

INIT 

89 

IOTBL  (3«LOCl)  xBITPUTf  IOTBL  (3 , L OC 1 ) , NA RG,  7) 

INI  T 

90 

IF CNEKT( JPTR)  *EQ.  EQUALS)  GO  TO  32 

INIT 

91 

GO  TO  40 

INIT 

92 

12  IF  (BITGET (IOTBL f3«LOC) ,1, 1)  .NE*  1)  GO  TO  7 

INIT 

93 

C»*  VARIABLE  IS  OIMENSIOtCO 

INIT 

94 

C**  SET  TYPE 

INIT 

95 

CALL  IHPTYP 

INIT 

96 

LHSTYP-BITGET  C 10 T BL ( 3 , LOC ) • 1 0 , 3) 

INIT 

97 

IFILHSTYP  *EO*  6)  NTYPE*2 

INIT 

98 

JPTRsIPTR 

INI  T 

99 

JBLOCKsNBLOCK^ 1 

INIT 

100 

PARSE  THE  LEFT-HAND  SIDE 

INIT 

101 

CALL  EXPR 

INIT 

102 

CALL  PARSE 

INIT 

103 

C»*  STORE  BASIC  BLOCKS 

INIT 

106 

CALL  BLKSTR 

INIT 

105 

IBLOCK(JBLOCK)«IBLOCK(JBLOCK)  - 1000 

INIT 

106 

GO  TO  32 

INIT 

107 

C**  Slt^LE  VARIABLE*  STORE  IN  BASIC  BLOCK  TABLE 

INIT 

100 

30  N6LOCK«NBLOCK«i 

INIT 

109 

JBLOCKsNBLOCK 

INIT 

110 

IBLOCK(NBLOCK) •lOOO^LOC 

INIT 

111 

32  NTMS*0 

INIT 

112 

IPT»*JPTR 

INIT 

113 

C**  PAPSf  THE  RIGHT -HAMO  SIDE 

INIT 

116 

CALL  EXPR 

INIT 

115 

IFfJPTP  .LE.  N)  CALL  ERR0RI7) 

INIT 

116 

call  parse 

INIT 

117 

C**  PROCESS  FUNCTION  REFERENCES 

INIT 

116 

CALL  FNCSTR 

INIT 

119 

C**  CHECK  IF  ASSIGNNENT  IS  LEGAL 

INIT 

1?0 

CALL  EXPRCK 

INIT 

1?1 

IFTITYP  .EQ,  3SI  GO  TO  36 

INIT 

i?2 

C**  STORE  BASIC  BLOCKS  FOR  RIGMT«MANO  SIDE 

INIT 

1?3 

call  blkstr 

INIT 

1?6 

I0LOCKCN8LOCK»l)*IBLOCK( JBLOCKI 

INIT 

125 

00  36  KsJBLOCKtNBLOCK 

INIT 

126 

36  IBL0CK(K}«IBL0CK(K«1) 

INI  T 

127 

IFCLTVP  .EQ.  1)  RETURN 

INIT 

126 

36  IFTHOOC  .NE.  n GO  TO  3S 

INIT 

129 

IFCRMSTYP  .EO*  3 .OR.  RMSTYP  .EO.  61  RETURN 

INIT 

130 

IF  CNSTR  .IT.  6 > RETURN 

INI  T 

131 

JPTR*IPTR-1 

INIT 

132 

C**  VARIABLE  PRECISION  MODE 

INIT 

133 

C»*  GENERATE  CALLS  TO  VARIABLE  PRECISION  SUBROUTINES 

INIT 

136 

call  CNVRT 

INIT 

135 

RETURN 

INIT 

136 

C**  ROLL  CALL  MODE 

INIT 

137 

C**  GENERATE  CALL  TO  -ROLCHK-  IF  NECESSARY 

INIT 

138 

35  IFTNFUNC  .EO.  0)  RETURN 

INIT 

139 

IFCIFN  .EQ.  11  RETURN 

INIT 

161 

C**  LOOK  AT  EVERY  FUNCTION  CALL  IN  STATEHENT 

INIT 

161 

00  36  J^l.NFUNC 

INIT 

162 

LOCsFNCL  OCUT 

INIT 

163 

INOEXsBITGETf IDTBLC3.L0C) t 36.R) 

INIT 

166 

KLAS«BITGET (I SUBL T ( 2 • INOE X I , 10,61 

INIT 

165 

IFIKLAS  .NE.  1 .ANO.  KLAS  .NE.  ?f  GO  TQ  36 

INI  I 

166 

C**  SUBROUTINE  OR  FUNCTION  HOOULE  - ISSUE  A CALL  TO  HOLCMK* 

INIT 

167 

CALL  CALL? 

INI  T 

166 

RETURN 

INIT 

169 

36  CONTINUE 

INIT 

150 

RETURN 

INI  T 

151 

60  CALL  ERR0R(7I 

INIT 

152 

RETURN 

INIT 

153 

50  CALL  ERR0R(15T 

INIT 

156 

RE TURN 

INIT 

155 

60  CALL  ERR0RT6B) 

CYS8» 

10 

RETURN 

CY58» 

11 

END 

INIT 

156 

SUBROUTINE  INTRIN 

INTRIN 

COHNON  • 113261  ,0 (SOO 1. IDTBL(8tS00).INITl 0(31 ,L  8STI0I3T .ISRCHI3) , 

RICH 

• JPTR.N.N,  JTTP,LST*RT.N2,IFNCNN,L0GI0iNXTID,  ID  TT  P,  NIO  t IOC  t 

CY5  6A 

80 

2 LTTP, ITTP, IBL HOT, NODE, lERR.IOES 

RICH 

CONNON/L  IST/Nl  IST.NINTFCt  I SUBLT  12,2001  ,INTF*C(  3001 

INTRIN 

INTEGER  BITGET 

INTRIN 

c** 

THIS  ROUTINE  IS  CALLED  AFTER  PROCESSING  THE  HOOULE,  TO  CHECK  THAT 

INTRIN 

NO  INTRINSIC  FUNCTION  NAMES  HAVE  BEEN  MISUSED 

INTRIN 

00  100  I>1,W.IST 

INTRIN 

IFIBITGETIISUBLT(2,II,10,NI  ,NE.  NI  go  to  100 

INTRIN 

c»» 

GET  MEKT  intrinsic  FUNCTION  NAME  FROM  SESCf^HP  LIST 

INTRIN 

10 

NKTIO'ISUBLTI  1,11 

INTRIN 

11 

c»* 

SEARCH  SYMBOL  TABLE  FOR  NAME 

INTRIN 

12 

call  search 

INTRIN 

13 

CALL  CONSCH 

INTRIN 

16 

IF  FOUND,  ISSUE  diagnostic 

INTRIN 

15 

IFtlSRCHIK  ,EO.  1 .OR.  ISRCH(3)  .EO.  It  CALL  ERRORITi,  .NYTIOI 

INTRIN 

16 

100  CONTINUE 

INTRIN 

IT 

RETURN 

INTRIN 

16 

FNO 

INTRIN 

19 

/() 


SU6R0UTINC  10 

10 

2 

CONNON  A <13261  «0 ( 500 1 « lOTBt < 8, 600 1 , IN  I Tl Of  31 ,L ASTI  01 3) , ISRCH < 3 1 « 

RICH 

2 

• JPTR»N,N, JTVP,LSTART«N2« IFNCHH,L06tO«NXTlO, 10 TYP, NX 0* LOG  • 

CY58A 

SI 

2 LTTP* ITYPtlSt KDTtNOOetlCRPflOFS 

RICH 

6 

COHNON/STRlNG/NTYPC,NSTR,STR  <50  01 

10 

6 

COHHON/L ABCLS/STATRAI 2,200 »,NL ABEL 

10 

5 

COHNQN/BASBUC/IBLOCKC250  0)  ,NBLOCK,NB,NBR»CH 

CY5  6A 

33 

COHNON/INPOUT/NCALL, IN,IOP 

10 

7 

OIHENSION  IALPH1(6),IALPH2I5), IALPH3<6> 

10 

8 

INTEGER  A,STATRA,RPAR,C0HHA,BLANK 

10 

9 

INTEGER  6ITPUT tSITGET 

10 

18 

DATA  LPAR/1H(/,RPAR/1H)/ ,C0HHA/1H,/,BLANK/1H  / 

10 

11 

DATA  <IALPH1(  I)  ,I«l,%)/lHRaHC,lHA,lHO/ 

10 

12 

DATA  < IALPH2< I ) , I«1 , 51 /I HM ,1HR , IHI , IH T ,1  HE/ 

10 

13 

DATA  <IALPH3<n,I«l,8l/lHCflHO,lHN,lHT  ,1  HI  , 1 HN  ,1  HU  ,1  HE/ 

10 

16 

€••  I/O  STATEMENT  PROCESSOR 

10 

15 

IFRNT-0 

10 

16 

IFflTYP  •EQ«  121  GO  TO  10 

10 

17 

00  5 I«l,«i 

10 

IS 

IF<NEXTIJPTR)  .NE.  lALPHlCIII  GO  TO  50 

10 

19 

5 CONTINUE 

10 

20 

GO  TO  20 

10 

21 

WRITE  STATEMENT 

10 

22 

10  DO  15  I«l,5 

10 

23 

IF  <NEXT  ( JPTR)  .NE*  IAtPH?fin  GO  TO  50 

10 

26 

15  CONTINUE 

10 

25 

20  IF (NCXTfJPTRI  .NE*  LPARI  GO  TO  50 

10 

26 

C**  GET  I/O  DEVICE 

10 

27 

CALL  GNLE 

10 

28 

C^»  IF  NOT  VARIABLE*  ISSUE  DIAGNOSTIC 

10 

29 

IFUTYP  .EQ.  2»  GO  TO  22 

10 

30 

C**  READ  STATEMENT 

10 

31 

CALL  ERROR(22) 

10 

32 

GO  TO  28 

10 

33 

C**  VARIABLE  I/O  DEVICE  - GET  SYMBOL  TABLE  LOCATION 

10 

36 

22  call  SEARCH 

10 

35 

IF<ISRCH(2)  «EQ«  1)  CALL  E RROR ( 1 0 , NX T ID) 

10 

36 

IFdSRCHCll  .EQ.  n GO  TO  25 

10 

37 

lOTYP  *1 

10 

38 

CALL  STORE 

10 

39 

LOC*NIO 

10 

60 

C»*  CHECK  THAT  THE  DEVICE  IS  INTEGER  VARIABLE 

10 

61 

25  CALL  IMPTYP 

10 

62 

IF  (BITGET  <IOTBL<3,LOC)  *1,  1)  .EQ.  1)  CALL  ERROR  11  ^ , NX T 1 01 

10 

63 

IF1BITGET<I0TBL<3, LOCI  *10,3)  .NE,  h)  CALL  ERROR<22) 

10 

66 

C**  STORE  IN  BASIC  BLOCK  TABLE 

10 

65 

NBL0CK:N6L0CK» 1 

10 

66 

IBLOCK INBLOCKI «2000«LOC 

10 

67 

28  IF  <NEXT  (JPTRI  •EQ.  COMHAI  GO  TO  60 

10 

68 

JPTRsJPTR-1 

10 

69 

GO  TO  30 

10 

50 

C**  FORMATTED  I/O  STATEMENT  - GET  STATEMENT  NUMBER 

10 

51 

60  CALL  GNLE 

10 

52 

IFIJTYP  .NE.  51  GO  TO  26 

10 

53 

C**  GET  STATEMENT  NUMBER  TABLE  LOCATION  AND  SET  -REFERENCED"  FLAG 

10 

56 

call  stsrch 

10 

55 

STATRA  <2,L0C) * 81 TPUT (STA TRA ( 2, LOC 1 • 1 * 1 21 

10 

56 

GO  TO  29  10 

26  IFIJTYP  .NE«  2)  GO  TO  50  10 

C**  VARIABLE  FORHAT  - GET  SYMBOL  TABLE  LOCATION  10 

CALL  SEARCH  10 

IF(ISRCH(2I  .EQ.  1)  CALL  ERROR (10 «NXTIOI  10 

IF(ISRCH(II  ,EQ.  l>  GO  TO  27  10 

I0TYP«1  10 

CALL  STORE  10 

LOC*NIO  10 

27  CALL  IW»TYP  10 

C**  CHECK  THAT  VARIABLE  FORHAT  IS  AN  ARRAY  TO 

IF(BITGET(IOTBL(3*LOC)  •l,ll  .NE,  U CALL  ERRORI43)  10 

29  IFRHT*1  10 

31  IF (NEXT( JPTR»  .NE.  RPARI  GO  TO  50  10 

IF (NEXT ( JPTR)  .NE.  BLANKI  GO  TO  35  10 

C»*  NO  I/O  list  - MUST  NOT  BE  UNFORMATTED  WRITE  10 

IFdTYP  .EQ.  12  .ANO.  IFRNT  ,E0.  01  CALL  ERR0R(44I  10 

GO  TO  36  10 

C»^  STATEMENT  HAS  AN  I/O  LIST  10 

35  JPTR»JPTR-l  to 

C**  PARSE  THE  I/O  LIST  10 

CALL  EXPR  10 

NTYPE«3  10 

CALL  PARSE  10 

C**  STORE  BASIC  BLOCKS  10 

CALL  lOSTR  10 

36  IF(N00E  •NE.  1 .AND.  ITYP  .EQ.  Ill  GO  TO  37  10 

RETURN  to 

C**  READ  statement  IN  ROLL  CALL  MODE  10 

37  IFdTYPEd)  .EQ.  2)  GO  TO  42  10 

C**  MAKE  READ  STATEMENT  A COMMENT  STATEMENT  JO 

A(1)*1HC  10 

RETURN  10 

C**  STATEMENT  HAS  LABEL  - GENERATE  CONTINUE  STATEMENT  WITH  SAME  LABEL  10 
42  MRITE(I0P,4S)  ( A ( 1 1 « Is  1 , 6 I * ( t A LPH3  ( 1 1 • I«  1*  8 I 10 

45  FORMAT (72A1)  10 

C**  MAKE  READ  STATEMENT  A COMMENT  ANO  DELETE  LABEL  10 

A 1 1 1 * 1 HC  10 

DO  47  1=2.6  10 

47  A(  n«lH  10 

RETURN  10 

50  CALL  ERR0R(7)  10 

RETURN  10 

END  10 
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SUBROUTINE  lOSTR 

COHNON  A(13?6I  «0(500)«IOTBL<efSO(ll«INITID(31  ,L*STIO(3)  ,ISRCH(3I« 
• JPTR,N,M, JTYP,L START, N2, IFNCNH, L OGI 0 , NX TIO, TO TYP, N 10 , LOG , 

2 LTYP,ITYP,IBL<OT,MOOE,IERR,IOFS 
C0HH0N/FUNC/IFNCRA(S,121  ,HARGS,  IAR6S  (SOI  ,FNCL0CC  S I • NFU  NC 
COHHON/BAS8LK/IBLOCK(?5aO) , NRL OCr ,N0 , NBR NCH 
integer  BITGET 

C**  this  routine  is  CAlCEO  after  parsing  an  I/O  LIST,  TO  STORE 
C**  INFORMATION  IN  THE  BASIC  BLOCK  TABLE 
00  100  Isl,NARGS 
INCREMENT  BLOCK  COUNTER 
NBLOCK  = NBLOC»(^  1 
ICOL*20*MOO(I-1,3I^IO 
lVR~il*2)/3 

GET  SYMBOL  TABLE  LOCATION  OF  VARIABLE 
LOC'BITGETf lARCSf IVR), ICOL ,10) 

C**  GET  CLASS  OF  VARIABLE  ISUB*0  - I/O  VARIABLE 

C**  ISUB=1  - SUBSCRIPT 

C**  ISU8-3  - implied  00  IWEX 

iSUBsBiTCET (lARCSIIVR) ,IC0L»S,?) 

IF (ISUB  .EQ,  1 ) GO  TO  RQ 
IFIISUB  .EO#  2i  60  TO  ?0 
IFUTYP  .EQ.  Ill  60  TO  SO 
IFIITYP  .EO.  12)  60  TO  90 

2 0 IOEF«BITG£T (IAR6S  f I VR I , ICOL^ 10 ,6 1 
C**  IMPLIED  00 

NM0VE»I-IDEF-1 

C**  HOVE  00  INDEX  TO  BEGINNING  OF  BLOCK 
00  30  J«l,NMOVE 
ITEMP=NBLOCK- J 

3 0 I8L0CK(IT£MP»l)«IBL0CKaTEMP) 

IBLOCK (ITEMP) slQOO^LOC 
C**  UNOEFINE  00  INDEX  AT  END  OF  BLOCK 
N6L0CKsNBL0CK«l 
IBLOCK(NBLOCX) «BOOO«LOC 
GO  TO  100 

C**  VARIABLE  IS  OEFINEO  - STORE  IN  BASIC  BLOCK  TABLE 
$0  IBLOCKCNBLOwO «tOOO^LOC 
GO  TO  100 

C»*  VARIABLE  IS  REFERENCED  - STORE  IN  BASIC  BLOCK  TABLE 
90  ISL0CK(N8L0CKI >2000»LOC 
10  0 CONTINUE 
PElUffH 
ENO 


iostr 

2 

RICH 

2 

CY5  SA 

SO 

RICH 

k 

CY58A 

3<» 

CY58A 

35 

IOSTR 

6 

iostr 

7 

I OS  tr 

8 

IOSTR 

9 

lOS  TR 

10 

iostr 

11 

los  tr 

12 

iostr 

13 

IOSTR 

lA 

iostr 

15 

iostr 

16 

I OS  TR 

17 

iostr 

18 

I OS  tr 

19 

iostr 

20 

I OS  tr 

21 

ros  TR 

22 

lOS  tr 

23 

iostr 

2V 

IOSTR 

2V 

los  tr 

26 

iostr 

27 

iostr 

28 

iostr 

29 

IOSTR 

30 

los  tr 

31 

IOSTR 

32 

IOSTR 

33 

lOS  tr 

36 

I OS  tr 

35 

iostr 

36 

IOSTR 

37 

I OS  tr 

38 

IOSTr 

39 

iostr 

60 

iostr 

61 

I OS  tr 

62 

iostr 

63 

FUNCTION  IPReV(ia» 

COMMON  A (132b>  ,O<500  ),  IOTBU8,500>  ,INITIOf3»  ,L  AS  T lO  ( 3 » , ISRCH  ( 3 ) * 
• JPTP,N,M,JTVP,LSTART,N?,  IFNCNN,LOGIO,NXTIO»  IOTYP,NIO#LOCf 
2 LTYP,  ITYP,I0LKOT,MOOE,IERR»IOCS 
INTEGER  4,8L4NK 
DATA  8LANK/1H  / 

C**  THIS  FUNCTION  CALLS  -ITYPE-  TO  GET  THE  CLASS  OF  THE 
C**  PREVIOUS  character 
00  10  I«1,N 
J=TA-I^1 

IF(J  *EQ.  01  GO  TO  20 
IFU(J)  .EQ.  8LANK»  GO  TO  10 
IPREV«ITYPE  <J» 

JPTR=J-1 
return 
Ifl  CONTINUE 
20  IPREV*3 
JPTR=8 
RETURN 
END 


function 

ITYPE ( lOI 

ITYPE 

2 

COKHON  » ,0(500), lOTBLC  B.5001  , INITI 0(3) ,L  »ST 10 131 ,ISRCH(3 1, 

RICH 

2 

• JPTR.N, 

N,  JTTP  ,LST»RT,NE,  IFNCNH,  t OGI 0 , NX  TIO  , 10  TY  P,  NIO,  L OC  , 

CY5  8A 

SO 

2 LTYP,lTTP,IBLKOT,MOOE,IERR,rOFS 

RICH 

6 

INTEGER 

BITGET 

ITYPE 

k 

c»»  this  function  c»lls  -next-  to  get  the  next  ch»r»cter  in  the  input 

ITYPE 

5 

c**  STRING  ANO 

RETURNS  ITYPE*!  - LETTFR 

ITYPE 

6 

c** 

ITYPE*?  - OIGIT 

ITYPE 

7 

C** 

ITYP£*3  - OTHER 

ITYPE 

8 

Nirr«NEYT  f 10  1 

ITYPE 

9 

IVAL^BITGET (NXT«6,6I 

ITYPE 

10 

C****IF  UNIVAC 

110«  - PL*CE  • ~C-  IN  COLUNN  I OF  NEXT  TNO  CXROS 

ITYPE 

11 

ifiival 

,GE.  IRX  ,XNO.  IV*L  ,LE.  IR?)  GO  TO  10 

ITYPE 

12 

IF  IIVAL 

.GE.  IRO  .AND.  IVXL  •LE.  1R9)  GO  TO  ?0 

ITYPE 

13 

C****1F  COC  67 

00  - PL»CE  » “C-  IN  COLUMN  1 OF  NEXT  TNO  C»ROS 

ITYPE 

Ik 

C IFIIVAL 

.GE.  06  .XNO.  IVXL  .LE.  03?)  GO  TO  10 

ITYPE 

15 

C IFUVAL 

.GE.  060  .RNO.  tViL  .LE.  071)  GO  TO  ?0 

ITYPE 

16 

ITYPE*3 

ITYPE 

17 

IFCIVAL 

.GT.  IR.)  C*LL  ERR0R(?3) 

ITYPE 

16 

RETURN 

ITYPE 

19 

10  irypE»i 

ITYPE 

20 

RETURN 

ITYPE 

21 

20  ITYPE-2 

ITYPE 

22 

RETURN 

ITYPE 

23 

ENO 

ITYPE 

29 

IPREV 

2 

RICH 

2 

CY58A 

80 

RICH 

k 

IPREV 

k 

IPREV 

S 

IPREV 

6 

IPREV 

7 

IPREV 

8 

IPREV 

9 

IPREV 

10 

IPREV 

11 

IPREV 

12 

IPREV 

13 

IPREV 

19 

IPREV 

15 

IPREV 

16 

IPREV 

17 

IPREV 

IS 

IPREV 

19 

SU8R0UTINE  L06CHK 

LOGChk 

2 

COMMON  1,0(500).  ID  TBL(S, 5001, INI  TI  0(31, LASTIOC]),  ISRCH(3  I, 

RICH 

2 

• JPTP,N,H, JTYP,lSTART,N2, IFNCNM,L06I0, MXTIO, 10 TYP, Nl 0, LOC t 

CY56A 

ao 

e LTYp, ityp,i9lkdt,hooc.ierr* ides 

RICH 

k 

COMMON/LOGIC/ LOG* LOGS! 

LOGChk 

DIMENSION  LX0P(li)»L0GRA(5) 

logchk 

5 

DATA  (LOGOPCn  • I = 1 . 1 1 ) /2 Ht T*  2HL E , 2HGT  , W GE • 2 HE  0,  2MNE  , ^HOP * 

3HAND» 

LOGCHK 

6 

• 3HNOT  ,4HTRUE  t 5HFALSE/ 

LOGCHK 

r 

JPTRsLOGST 

logchk 

8 

C**  FORM  CHARACTER  STRING  CONTAINING  LOGICAL  OPERATOR 

LOGCHK 

9 

DO  10  I3l,6 

LOGCHK 

10 

NXT*NE)rMJPTRI 

logchk 

11 

IF  <NKT  , EQ.  IH. 1 CO  TO  12 

logchk 

12 

lO  LOGRA(I)>NXT 

logchk 

13 

GO  TO  20 

LOGCHK 

1^ 

12  IFtI  bLT.  3>  GO  TO  20 

logchk 

19 

C**  PACK  THE  logical  OPERATOR 

LOGCHK 

16 

CALL  CAA  aOGRA  ,I-l,LOG) 

logchk 

17 

C»^  COMPARF  WITH  VALID  OPERATORS 

logchk 

16 

DO  15  I«l.ll 

logchk 

19 

IFaOC  .EQ.  LOGOPIII)  GO  TO  30 

logchk 

20 

C**  THIS  ROUTINE  CHECKS  TO  SEE  IF  A LOGICAL  OPERATOR  OR  CONSTANT 

IS  VALI 

logchk 

21 

15  CONTINUE 

logchk 

22 

20  LOG«0 

logchk 

23 

C**  INVALID  OPERATOR 

logchk 

2<* 

RETURN 

logchk 

25 

30  LOGsl 

logchk 

26 

C**  valid  OPERATOR 

logchk 

27 

LOGIO*I 

logchk 

26 

return 

logchk 

29 

END 

logchk 

30 

SUBROUTINE  tOGIF  LOGIF 

COMMON  Aa326)«OtSOOI,IOTeL(8,5QOI«INITIOOl.LASriO(3),  ISRCHI3  ),  RICH 
• JPTR,N,H,jTYP.LSTART*He, I FNCNM, L OGI 0 • NX TIO, 10 TYPf HID* LOC t CY58A 

2 LTYP, ITYP,IBLKOT,MOOEtlERRf lOFS  RICH 

C0MH0N/STRING/NTYPE,NSTR,STR 1500)  LOGIF 

COMHON^BASBLK/IBLOCK  C250  0) tNBL OCX .NB *NBR NCH  CY5  8A 

INTEGER  A,STR,  Blank,  AY  ,EF  LOGIF 

DATA  LPAR/1M|/,0LANK/1H  / , AY /1M  1/ ,EF/ 1 HF  / LOGIF 

C**  -LOGICAL  IF-  STATEMENT  PROCESSOR  LOGIF 

IF(N£XT{ JPTR)  ,NE,  AY)  GO  TO  IIC  LOGIF 

IFINEXn  JPTR)  .NE.  ED  GO  TO  110  LOGIF 

IF(NEXnjPTR)  ,NE,  LPAR)  GO  TO  llO  LOGIF 

JPTRsJPTR-1  LOGIF 

C*»  PARSE  THE  LOGICAL  EXPRESSION  LOGIF 

CALL  EXPR  LOGIF 

NSTR=NSTR»1  LOGIF 

STRCNSTR)s  -5  LOGIF 

NTYP£=?  LOGIF 

CALL  PARSE  LOGIF 

C**  PROCESS  FUNCTION  REFERENCES  LOGIF 

CALL  FnCSTR  LOGIF 

C**  STORE  BASIC  BLOCKS  LOGIF 

CALL  BLKSTR  LOGIF 

IFIITYP  ,GT.  15)  GO  TO  130  LOGIF 

LTYPrl  LOGIF 

C»*  PROCESS  STATEMENT  FOLLOWING  LOGICAL  EXPRESSION  BY  GOING  TO  THE  LOGIF 

C**  APPROPRIATE  STATEMENT  PROCESSOR  LOGIF 

GO  TO  110,20,  30,40,50 • GO ,70,80 ,70 ,70,90, BO,  100  ,100,100  ) ,ITYP  LOGIF 

10  CALL  INIT  LOGIF 

return  LOGIF 

20  CALL  ASSIGN  LOGIF 

return  LOGIF 

30  CALL  GOTO  LOGIF 

35  N6L0CK*NBL0CK^1  LOGIF 

I0LOCK (NBLOCKI sBB8  LOGIF 

NBRNCHr?  LOGIF 

RETURN  LOGIF 

40  CALL  ASGOTO  LOGIF 

45  NBLOCKsNBLOCK^ I LOGIF 

TBLOCK (NBLOCK) =9B8  LOGIF 

NBRNCHsNBRNCHfl  LOGIF 

return  LOGIF 

50  CALL  CTGOTO  LOGIF 

GO  TO  45  LOGIF 

60  call  ARIF  LOGIF 

GO  TO  45  LOGIF 

70  CALL  SIMP  LOGIF 

IFIITYP  ,EO.  7)  return  LOGIF 

GO  TO  35  LOGIF 

80  CALL  CALL  LOGIF 

RETURN  LOGIF 

90  TALL  to  LOGIF 

return  LOGIF 

100  CALL  AUXIO  LOGIF 

return  LOGIF 

110  CALL  ERRORI7)  LOGIF 

return  LOGIF 

130  CALL  ERRORI45)  LOGIF 

return  LOGIF 

END  LOGIF 
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SUBROUTINE  LOOPCK 

LOOPCK 

2 

COHMON/L ABELS /ST ATRA<?, 2001, NL ABEL 

LOOPCK 

3 

COMMON/OOLOOP/  ISTACKU,5  0)  ,NST  AC  K , I L OOP 

LOOPCK 

k 

CONNON/eASBLK/I8LOCKI3500) «NBL 0CK«N8 « NBR NCH 

CV58A 

^9 

INTEGER  STATRA *BITGET 

LOOPCK 

6 

THIS  ROUTINE  IS  CALLED  APTER  HOOULE  PROCESSING  TO  CHECK 

00  LOOP 

LOOPCK 

7 

C**  STRUCTURE 

L 00  PC  K 

8 

IFfNSTACK  .E3«  0>  RETURN 

LOOPCK 

9 

C**  START  AT  BEGINNING  OF  BASIC  BLOCK  TABLE 

LOOPCK 

10 

IBLKST*! 

LOOPCK 

11 

C**  GET  LAST  LOCATION  IN  BLOCK 

LOOPCK 

12 

10  IBLKNO*BITGET ( IBL OCK <1 BL KST) 

LOOPCK 

13 

C**  GET  LOOP  WHICH  CONTAINS  BLOCK 

LOOPCK 

Ih 

L00P^»6ITGET( I 8L OCK (IBLKST » t 1 ^ t 61 

LOOPCK 

15 

C**  GET  NO,  OF  BRANCHES  FROM  BLOCK 

LOOPCK 

16 

NBReBiTGETCIBL  OCKCIBLKSTI *6,61 

LOOPCK 

IT 

IFdftLKNO  .EG.  IBLKN0*N9L0CK 

L OOPCK 

18 

IST*IBLKN0-N8R»1 

LOOPCK 

19 

C**  this  loop  examines  all  8RANC«S  from  the  BLOCK 

LOOPCK 

20 

C**  and  CHECKS  that  THEY  ARE  VALID 

LOOPCK 

21 

00  100  I«IST,IBLKNO 

LOOPCK 

22 

JLOOP=LOOP2 

LOOPCK 

23 

IF<IBLXKII»  .GE*  996)  GO  TO  100 

LOOPCK 

2k 

IBLKsIBLOCKCI) 

LOOPCK 

25 

C**  GET  BASIC  BLOCK  WHICH  CONTAINS  BRANCH 

LOOPCK 

26 

NXTBLK^BITGET I STATRA(2*IBLK) *36,18) 

LOOPCK 

27 

C**  get  00  LOOP  WHICH  CONTAINS  T»C  BLOCK 

L OOPCK 

28 

KLOOPsBITGETC IBLOCKCNXTBLK) *1?*6) 

LOOPCK 

29 

IFIKLOOP  «EQ.  0)  GO  TO  100 

LOOPCK 

SO 

IFtJl.OOP  •EG.  0)  GO  TO  200 

LOOPCK 

31 

C**  BOTH  BLOCKS  ARE  CONTAINED  IN  00  LOOPS 

LOOPCK 

32 

Traverse  the  oo  stack  to  determine  if  branch  is  legal 

LOOPCK 

33 

50  IFCJLOOP  *EQ.  KLOOP)  go  to  100 

LOOPCK 

36 

JL00P*ISTACK<  3 *JL  OOP) 

LOO  PCK 

35 

IFIJLOOP  *EQ,  0)  GO  TO  ?Q0 

LOOPCK 

36 

GO  TO  50 

LOOPCK 

3T 

200  IBLK«IBLOCKa) 

LOOPCK 

58 

HRITE(6*201)  STATRAd*  IRLK) 

LOOPCK 

39 

201  FORMAT (6X*65H  ILLEGAL  TRANSFER  INTO  THE  RANGE  OF  A 00 

LOOP  AT 

STAT  LOOPCK 

40 

lEMENT  NUMBER*I6I 

LOOPCK 

41 

100  CONTINUE 

LOOPCK 

62 

IFMBLKNO  .EG.  NBLOCK)  RETURN 

LOOPCK 

63 

€••  GET  START  OF  NEXT  BLOCK 

L OOPCK 

66 

IflLKST*IBLKNn»l 

LOOPCK 

65 

GO  TO  10 

LOOPCK 

66 

END 

LOOPCK 

6T 

1 


SUBROUTINE  LV3LET 

COMHON/L  VAPGS/  IFUNC,  lARG,  I ftOO • I POS # I T t P,  IVAL  STHEn,NVAL, 

♦ IO$TRY,IVALS(10),ITVP1(10» ,NSKIP 

INTEGER  FLCSPC,FLOHSr,FL  lMSK,Fl?M$iC,FL5MSK,FLG67,REGaSP,TMIS 

♦ ,FL3NSK,FL4MSt(,SEQSPC 

COMHON/L  VVTRl/ MENS  7F,RFG  ASP,  NOnSPCt  1>  /L  VVTR  2/LSTSPC  < 11/ 

•LVVTPT/LNKSP*:  C 1 ) /LWTPfc/FLGSPC  ( II 
COHHCN/LVFLAG/^LOMSK,F\.1MSK,FL2MSK,FL3MSK,FII*HSK,FL5MSK*FLG67 
COHHON  /LVTA3L/  HAPS7E,HAPai  /LVVSEQ/  I SEQS  7,  SEOSPO  * 1 I 
OATA  NFLG02/137B/ 

<ONFLC=0 

C determine  direction  TO  PROCEED  FOR  HULTIYALUE  LISTS 
JPOS=IPOS 
IPOS=IABS(IPOSI 
TF(IA00.NE.-1I  go  TO  7<* 

IFCIARG.EQ.-ll  GO  TO  66 

iaoo=ifunc*iarg 

IF  CIAOO.GT.  MEMS7E ) IA0D=I  AOO-MEMS7E 
IFC  CFtGSPCn&OO)  .AN0.FL5HSK>  .EQ.O)  GOT099 

1 IF CNOOSPC IIADO) . EQ. IARG)  GO  TO  4 
C SEARCH  conflict  list  FQP  THE  FUNCTION 
lAPOsLNKSPCCIADO) 

IF C (FLGSPC C lAOD) . and.  FLSMSK)  .NE.0>  GO  TO  99 
GO  TO  1 

66  IAOO=IFUNC 

C TO  DELETE  A SOECtFIC  TYPE  OF  NODE  fINOEXEO  OELETFI,  GO  TO  72 

4 IFCITYP.NE.-l)  GO  TO  7? 

IFC  (flgspcciaoo)  .ano.flohs*o  .eo.oi  go  to  6 

ISAOO*LSTSPC(IAOO» 

C DELETE  ENTIRE  MULTIVALUED  FUNCTION,  RETRIEVE  "IRST  VALUE 
IVALsNOOSPCCISAOOl 

5 NYTAD0=LSTSPC  ( rSAOOl 
NOOSPC  nSAOO)  *NOOSPCCPEGASP» 

LSTSPC  CISAOOl * PE GASP 
LNrSPC  CISAOOl  *0 

FLGSPC  CISAOOl  *0 

LSTSPC  CNOOSPC  CPE  GASP  1 1 sISAOO 

NOOSPC  CRECASPI =ISA00 

IFCCFlGSPCCNYTAOOI.ANO.FLOHSKI .NE.OI  GO  TO  2 

ISAOO=NYTAOO 

GO  TO  5 

C FUNCTION  IS  SINGLE  VALUED,  RETRIEVE  VALUE 
6 IVAL=LSTSPCCIA00) 

2 IF  MFLGSPCIIADO)  .ANO.FlShSKI  .EO.OI  GO  TO  66 
NYFUNC*L NKSPC ( lAOOl 

IFMFLGSPCCNXFuNCI.ANO.FLSMSYJ  .NE.OIGO  to  10 

NOOSPC  CIAOOI^MOOSPCCNXFUNCI 

LSTSPC  Cl AODleL  STSPCC  NtFUNCi 

LNKSPC  n AOOI  = L NtCSPCCNXFUNCI 

FLGSPC  Cl  ADO) FLGSPC  C NY FUNC I 

FLGSPC  CIAOOMFLGSPCCIAODI  .OR.FLSMSY 

IF  UFLGSPCC  lAOOl  • AND.FLOHSKI  •EO.OI  GO  TO  9 

•fVAL*LSTSPCUAOOI 

6 •«'VAL-LSTSPC(YVAL> 

IF  t CFLGSPC  CLST  SPC  tVVALH  . ANn.FLOHSYl  .r  Q.  01  GO  TO  8 
LSTSPCCt(VALl*rAOO 
IAOO*NYFUNC 


L 

L 

L 

L 

L 

L 

L 

L 

L 

L 

L 

L 

L 

L 

L 

L 

L 

L 

L 
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L 

L 

L 

L 

L 

L 

I 

L 

L 

L 

L 
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L 

L 

L 

L 

L 

L 

L 

L 

L 

L 

L 

L 

I 

I 

I 

L 

L 

L 

I 
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VOL 

ET  2 

VnL 

ET  3 

VDL 

fT  4 

VOL 

FT  5 

VOL 

ET  6 

VOL 

FT  7 

VPL 

ET  8 

VOL 

ET  9 

VOL 

ETlC 

VDL 

ETll 

VPL 

ET12 

VOL 

ET13 

VOLET14 

VOL 

ET15 

VDL 

ETl6 

VOL 

ET17 

VOL 

ET18 

VPL 

ET19 

VPL 

ET20 

VDL 

ET21 

VDL 

ET2? 

VDL 

FT  2 3 

VOL 

ET24 

VPL 

ET25 

VOL 

ET26 

VOL 

ET27 

VOL 

ET28 

VPL 

ET29 

VOL 

ET30 

VOL 

ET  31 

VPL 

ET32 

VPL 

FT33 

VOL 

ET34 

VPL 

ET  35 

VPLET36 

VPL 

ET37 

VOL 

ET38 

VOL 

ET  39 

VOL 

ET40 

VPL 

ET41 

VOL 

ET42 

VPL 

ET43 

VOL 

ET44 

VOL 

ET45 

VOL 

ET46 

VOL 

ET47 

VOL 

ET4.8 

VPL 

FT49 

VPL 

ET50 

VOL 

ET51 

VOLETS? 
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fT53 
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ETS4 

VOL 

FT55 

VOL 

ET56 

VPL 

FT57 

VPL 
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10  NOOSPCa&OOIsNOOSPC(REGA$P)  LVnLET59 

USTSPC (TftOOJsRFGftSP  L VOLGT60 

LNKSPC (lAOOIsO  LVnLETei 

FLGSPC (IflOO)sO  LV0LPT62 

NOOSPC  aSTSPC  I lAOO)  l = IftOO  LVnLET6  3 

LSTSPC  tNOOSPC  < UOO» ) *1 AOO  LV0LrT6<i 

PETUPN  Lvotnes 

72  rF<  (FLCSPCaADOJ  . ANO.FLOHSIO  .Nf  .0  » GO  TO  ?0  LVDLET66 

TFCIPOS.Ne.il  GO  TO  LVOieTb? 

IF  (ITYP.EQ.3)  GO  TO  6 LV0LFT68 

ISTYP= (FLGSPCC IAOO) . ANO.FLGG7)  LVOL  ET69 

IF  CISTYP.EO.IT  YP  » GO  TO  6 LVOLET70 

99  IVAL=-1  LVOLETTl 

PETUON  LV0LET73 

?0  IN0=C  LVOLET73 

FLGSPC  CIAOOIsFLGSPCCIAOO) .OR.FL4MSK  L VOLET 74 

LAST  = IAOO  LVnLET75 

XF(JPOS)121, 99,21  LV0LET76 

l?l  LASTl  = LNKSPCCLSTSPCCIAOOI  > LV0LET77 

THIS=LAST1  LVOLET78 

GO  TO  27  L VOLET  79 

21  IF  (JPOS.LT.OI  GO  TO  80  LVOLET80 

THIS  = LSTSPCCLA$T»  LVOLFT81 

IFCCFLGSPCCTHIS) .ANO.FlOMSKI .NE.O)  GO  TO  99  LVOLET82 

GO  TO  27  LVOLET83 

80  THIS  = LNKSPC(LASTI  LV0LET84 

IF  (THIS. EO.LASTl I GO  TO  99  LVOLET85 

27  IF  (ITYP.  EQ.  3)  GO  TO  23  LVDLET86 

IS TYPs (FLGSPC (THISI. ANO. FLG67)  L VOLET 87 

IFdSTYP.EQ.ITYPI  GO  TO  23  LVOLET08 

22  LASTsThIS  LV0LET89 

GO  TO  21  LVOLET90 

23  INn=IND*l  LV0LET91 

IFdNO.NE.IPOSI  GO  TO  22  LVPLET92 

^ RETPIEVE  THE  IPOSTTH  OF  THE  KTyPTTh  VALUE  0fFOPE  OELETING  LV^LET93 

IVflL  = NOnSPC(TH IS)  L V0LET94 

HAOO=IAOO  LVnLET95 

IF (JPOS. GT.O)  CO  TO  55  LV0LFT96 

NFYTrLNKSPC(THIS)  LVOL  FT 97 

IFCTHIS. EO.LASTl)  GO  TO  8?  IVOLFT98 

LNKSPC  (L  AST)  = next  I V0LFT99 

GO  TO  83  L VOL  FIDO 

82  LNXSPC  (LSTSPC  ( lAOOn  sNFXT  LVDLEICI 

83  IF  (NEXT, EO.LASTl  ) GO  TO  84  LVOLE1C2 

LSTSPC(NEXT)=LAST  IVPLF103 

GO  TO  85  LVOLE104 

84  LSTSPC(IA00)*LAST  LVnLElC5 

85  IA00=TMIS  LVnLElOfc 

GO  TO  86  LVOLEIOT 

55  NEXT  = LSTSPC(THIS)  iVGLElCe 

IF  ((FtGSPr  (NEXT)  .ANO.FLOMSX)  .NE.O)  CO  TO  50  lvnLFlC9 

LNXSPC (NEXT)=L AST  LVHLEllO 

GO  TO  24  LVOLEUl 

50  LNKSPC  (LSTSPC  ( I AOOM  =L  AST  LVnLEll2 

24  IAOO*THIS  LVOLFUJ 

A A$T*LNKSPC( THIS)  LVOL Ell  4 

IF  I (FLGSPC (LSTSPC (JLAST) ) . ANO.^LOHSK)  . NF .0)  L N KS PC ( HE  X T ) = JL AST  L VPL  El  15 


LSTSPC  aaST)*Nf)(T  L VOL  file 

fl6  KLASTsLSTSPC* HAOOl  LV0Lfll7 

IP  (LNKSPCtKLASn  .Nf  ,KLAST»  GO  TO  10  LVOLfllS 

C LVHLE119 

C CONVERT  TO  SINGLF  VALUE  LIST  LVOLfl?0 

C LVOLEI?! 

LSTSPC  (HdOO)=NOOSPC IKLASTI  L VOL  El  22 

FLGSPC  (HdOD)s ( PLGSPCIMADO) . OR . FLGSPC ( KL A ST » I .A  NO.NFLG02  L VnLEl23 

FLGSPC  (XLAST)  = 0 LV0LE124 

LNKSPC (KLflST)  =0  L VOL  El 25 

NOOSPC  (XLAST) sNOOSPC (RFGASPI  L VOL  El 26 

LSTSPC (KLAST)  s re  GASP  LVnLE127 

NOOSPC  (LSTSPC ( KL AST n *KL AST  L VOL  El 28 

LSTSPC (NOOSPC (KLAST) )=KL AST  L VOL  El  29 

GO  TO  10  LVOL  E130 

74  IF  U (FLGSPC n A 00)  .AND. FLOHSK) . NE . 0 ) . OR . ( (FLGSP C ( I ADO » . AN0.FL2HSK)  LVOL  El  31 

• .EO.O))  GO  TO  99  LVOLE132 

LAST=LNKSPC(I  ADO)  LVOL El  33 

NE  VTsLSTSPC (I  ADD)  LVOL El  34 

LSTSPC (L AST)  = next  LVOL El  35 

IF((FLGSPC(NEXT)  .ANO.FLOMSK)  .NE.O)  GO  TO  10  LV0LE136 

LNKSPC  (NEXT)rLAST  LVOLE137 

CO  TO  10  LV0LF138 

68  NEXTrLNKSPCtlAOD)  LVOLE139 

NExTlsNEXT  LVOLE140 

25  IF (LNKSPC (NEXT IJ . EQ. lAOO)  GO  To  26  LV0LE141 

NFxTl*LNKSPC(NEXTi)  LVOL El  42 

GO  TO  25  LVnLE143 

26  LNKSPC (NEXTl) sNEXT  LV0LE144 

K0NFlC  = 1 LVr*tEl45 

GO  TO  10  LVOL El 46 

ENO  LVOLE147 


FORTRAN  Version 


SU«P0UTINE  LVFXIT (N) 

COHMON/L  VARGS/LVFUNCf  L VVftPG.LVVflO.CVVPOS  *C  VVTrP,  LVV4L. 

♦ LVHEftO,LVVNVL*LVOEST,LVVaLS( 10) ,LVTyPE 1101  »L VS  KIP 
COHMON/L VTABL/LVTSI?*L VHflP(  1) /L VV SEQ /L VS  I Z f . L VSQSP I 1) 

COHMON  /TYP/  NN(3),EPPELG 
rOHMON  /STRING/  NTYPE,N$TP 

common  /need/  start, ASSOCtLEVELfSTOP 
INTEGER  R,RT'MP,STJ, STACK, ASSOC, START, ST  OP 
COMMON  /GIRL/  HMflO) ,OPRANO 

common  /HL/  HOL, ACTrON,FUNCl ,FUNC?,EUNC3 ,LFPT,  PI GHT , ST R ING , M A Y J 
common  /NTIMES/  NTIMES,MAXI 

COmmON/NEEDS/STJ , JSTACK,R, JAS, J, JLAST ,RTEMP,ST  AC K (40  0) 

INTEGER  ST  RING,  HOL,  ACT  ION  , RI GHT  , FUNC  1 , EU  NC?  , FUKC3,OPRANO 
LOGICAL  ERRFlG 
GO  TO  25000 
2500  1 CONTINUE 

IF(MAXJ  ,NE.  0)  PRINT  10Q,HAYJ 

too  F0RM4TaY,44M  STATEMENT  IS  TOO  COMPLEX,  CORRECT  TO  CHAR,  ,13) 
TFIMAXJ  ,EQ.  0)  PRINT  20  0 , MA X I , NSTR 
20  0 FOPMAT(lX,29H  STATEMENT  TOO  LONG  AT  CHAR.  , I 3,  3H  OF, 13) 

C COMMENTS  USEO  IN  CASE  OF  GIRS  PROBLEMS  WHEN  )^MORY  U^EO  UP 
C GO  TO  10 

C IF (MAX J ,EQ.  0 ) GO  TO  50 

IF (MAX J ,EQ.  0 ) GOTO  10 
00  3C  NCHAR=1 , MAX J 
LVVPOS  s NCHAR 

LVVTYP  5 3 


LVFUNC=  HOL 

LVVARG=  STRING 

CALL  LVFIN0(LV2  A,LV2  B,LV2  C,LV2  0) 

IVl  AAO  = string 

IF  (LVVAL,NE.-1I  LVl  AAO  = LWAL 

LVl  AAI  = LVl  AAO 

LVVAO*-l 

LVVTYPs-1 

LVVPOS=l 

LVFUNC=  LEFT 

LWARG^tVi  AAI 
CALL  LVOLET 

LVl  AAI  * LVl  AAO 

LVVAOs-1 
L VVTYPr-! 

LVVPOS=l 


lvfunc*  right 

LVVARG=LV1  AAI 

CALL  LVOLET 

LVl  AAI  3 LVl  AAO 

LVVAO»-l 

LVVTYPs-l 

LVVPOSsl 

LVFUNC«  HOL 

LVVARG»LV1  AAI 

CALL  LVOLET 

LVl  AAI  • L VI  AAO 

IVVAOs-l 

lvvtyp«-i 

LVVPOS*! 


s 


LVPXIT  2 


LVFXIT  3 
LVFXIT  4 
LV'^XIT  5 
L VEX  IT  6 
LVFXIT  7 
LVFXIT  a 
LVFXIT  9 
LVFX  ITIO 
L VFXrni 
L Vf XIT12 


LVFXIT14 
LVFX IT15 
LVFXIT16 
LVFX  IT17 
L V'^XlTia 
LVf XIT19 
LVFXIT20 
LVFX  IT21 
LVFXIT22 


LVrUNC=  STi?rNG 
LV\/flPG  = LVl  flAI 
CfiLL  LVOLPT 

10  CONTINIJF  LV''XIT34 

LVVAD=-1 
LVVTVPs-l 
LVVPOS=l 

LVFUNC=  SrPING 

LVVflPG=  string 

CALL  LVOLET 

LVl  AAO  = OPPANO 

L VVAP=-1 
LVVTYP=-1 
LVVPOS-1 

LVPUNC=  OPRANO 

LVVARG  = L'/1  AAO 
CALL  LVOLCT 
LVVAO=-l 
LVVTVP=-1 
LVVPCS=1 

LVFUNC=  STRING 
LVVAPG=LV1  AAD 
CALL  LVOLET 
LVVAO=-l 

LVVTVP=-1 

L VVPOS=l 

LVFUNC=  ACTION 
LVVARGsLVl  AAO 
CALL  LVOLET 
LVVAO=-l 
LVVTYP=-l 
L VVPOSsl 

LVFUNC=  PUNCl 

LVVAPG=LV1  AAD 
CALL  LVOLET 
10  CONTINUE 
RFWINO  19 
NT  IMFS  = 0 
C 10  CONTINUE 
C rewind  9R 

C NTIH£S=0 

JsNSTR  ♦! 

P=*“TOP 
ST  J*R 

FRPFLGs. TPUE. 

JSTACK=1 

STACKUSTAC*0  =SHIFT(ST0P*45>  .OP.  SM I F T I 100  • 30  » .OR.  ShiFT(J,15)  LVF*IT3B 


c 

NS  TPs  0 

LVFXIT39 

NSTRsHAX  j 
PF  TURN 

L VFX IT40 

?5  00  0 

CONTINUE 
LV?  A*LV2 

GO  TO  ?S001 
ENO 

B=LV? 

C'LV? 

0*0 

L VFX  ITe/ 
L Vc-X  IT?0 
LvrxiT?9 
L Vf XIT30 
LVFXIT31 
LVPXIT3? 
LVFXIT13 
LWPXIT34 
L VEXIT3S 
L VFX  IT  36 
LVPXIT17 


GIRL  Version 


% 

SUBROUTINE  LVEXIT(N( 

LVEXIT 

3 

COMMON  /TYP/  NNCIt.ERRFLG 

LvexiT 

3 

COMMON  /STRING/  NTYPE.NSTR 

LVeXIT 

k 

COMMON  /NEEO/  START, ASSOC, LEVEL tSTOP 

LVEXIT 

5 

INTEGER  R, RTE M P, ST J, STACK, ASSOC, START, ST  OP 

LVEXIT 

6 

COMMON  /GIRL/  MM  (19)  ,OPRANO 

LVEXIT 

7 

COMMON  /HL/  HOL, action, FUNC1,FUNCZ,FUNC3, LEFT,  RIGHT, STRING, HAXJ 

LVEXIT 

6 

COMMON  /NTINES/  NTINES,MAXI 

LVEXIT 

9 

COMNON/NEEOS/STJ,  JSTACK,R,  JAS,  J,  JLAST  ,RTEMP,ST  ACKIGM I 

LVEXIT 

10 

INTEGER  STRING,H0L,ACTI0N,RIGHT,FUNC1,FUNC2,FU(C3,0PRAM) 

LVEXIT 

11 

LOGICAL  ERRFLG 

LVEXIT 

13 

G 

EXECUTE 

LVEXIT 

13 

IF(MAXJ  ,NE.  01  PRINT  100,MAXJ 

LVEXIT 

14 

180 

FORMAT  (IX, 44H  STATEMENT  IS  TOO  COMPLEX.  CORRECT  TO  CHAR.  ,131 

LVEXIT 

15 

IF(HAXJ  .EQ.  01  PRINT  ?00,MAXI,NSTR 

LVEXIT 

16 

30  0 

FORHAT  (IX,B9H  STATEMENT  TOO  LONG  AT  CHAR.  , 1 3,  3H  OF, 13) 

LVEXIT 

17 

C 

COMMENTS  USED  IN  C*SE  OF  GIRS  PROBLEMS  NMEN  MEMORY  USED  UP 

LVEXIT 

IS 

C 

GO  TO  10 

LVEXIT 

19 

C 

IF(MAXJ  .EO.  0)  GO  TO  SO 

LVEXIT 

30 

IF(HAXJ  .EO.  0)  GO  TO  10 

LVEXIT 

31 

00  30  NCHAR<1,MAXJ 

LVEXIT 

33 

G 

STRING»HOL.NCHAR(-LEFT,-RIGHT, -H0L,-STRI NG) 

LVEXIT 

33 

30 

CONTINUE 

LVEXIT 

34 

G 

STRING-STRING 

LVEXIT 

35 

G 

OPRANO(-OPRANO,-STRINC,-ACTION,-FUNC1) 

LVEXIT 

36 

10 

continue 

LVEXIT 

37 

REMIND  19 

LVEXIT 

3B 

NTIMES-0 

LVEXIT 

39 

C 

10 

CONTINUE 

LVEXIT 

30 

C 

REMTNO  99 

LVEXIT 

31 

c 

NTIMES*0 

LVEXIT 

33 

J*NSTR»1 

LVEXIT 

33 

r»stop 

LVEXU 

34 

STJ*R 

LVE  XIT 

35 

ERRFLG*. TRUE. 

LVEXIT 

36 

JSTACK*! 

LVEXIT 

37 

STACK(JSTACK)*SHIFT(STOP,G5)  .OR.  SMI  FT  ( 10  0 , 30  ) .OR.  SMIFT(J,15) 

LVEXIT 

3S 

c 

MSTR«0 

LVEXIT 

39 

NSTR«NAXJ 

LVEXIT 

40 

G 

complete 

LVEXIT 

41 

subroutine  lvfechcni 

INTEGER  FLGSPC .SEOSPC, REGASP 

COMMON  /LVTABL/  MAPS7E»MAP(1)  /LVVSEQ/  I StOS  7,  SE  OSPC  ( 1 » 
COMMON/LVVTRl  /MEMS7E  *REGA$P*  NOOSPC  ( 1 ) /L  VV  TR  2/L  STS  PC  I II  / 

•LVVTR3/LNKSP:  C 1 1 /L VVT R«»/PLGS PC  I II 

COMMON/LVRANO/  KPRIME*KS,KX,KOY,KOX,t<TEHF 

RE  AO  (N)  MEHSZE  .REGASPt  KPR  I , < S , XX  , K TE  ST  ,XOY  TEHP,XOX  ,XNUM 

♦,iseos7 

PE  AO  (N  I (NOOSP,C  (II  . ! = !•  MEMS7EI 
PEAOINI (LSTSPC (II #I=1*MEMS7E> 

RE  AO (N I (LNKSPC ( 1 1 • 1= 1, ME  MS 7E ) 

PEAD(NI  (FLGSPCdl  ,I*1*MEM$7E) 

PEAO(N) (SEQSPC ( 1 1 , 1*1* ISEQSZI 
PRINT  10 

rORMATdH  *•  GRAPH  HAS  BEEN  PLACED  INTO  MEMORY*, //> 

RETURN 

FNO 


SUBROUT  I NC  L\/F  INO<  INOFX,  iNQXflO  ,KP  UNC  t Cl 
COMMON/LVflRGS/IFUNC.  URG.iaOO,  IPOS.ITYP,  IVAL  ,t  ST  MfO.NWAL, 

♦ IOSTPY,IVALS(lCI*rTYPieiOI,N^KlP. 

INTEGEP  FLGSPC,RFGASP,FtOMSK,PLlHSK,FL?MSK,PlT**SX,FL«*MSK,FLFHSH, 

♦ FLG67,SFQSPC 

COMMON/LVFLAG/FLOHSK,FLlMS<,FL?MSK*FL3HSIf,FLUHSX,FLSHSX,FtG67 

COMHON  /LYTABL/  H APS7F  , 1A  P f 1 1 /LVYSFO/  I SF  OS  7,  SF  OSPC  (1  > 

COMHON/t  WTPl /mEHSZF  ,RFGASP,  NOOSPC  ( 11  /L  V V TP  ?/ L$TS  PC  ( 11/ 

•L  VVTP3/LNKSPC  I 1)  /LVVTpl»/FtG<?PC  ( 1 » 

OATA  NFLAGA/367R/ 

IAOO=IFUNC»IAPG 

IF (IA00.GT.MFHS7F)  I AOO* I AOO -HC MS 7f 
LSTH£0=0 

IF  ((PLGSPCnAOOl  .AN0.F15MSK)  .FO.O)  GO  TO  90 

I IF (NOOSPC( lAOD) • FQ, lARG)  GO  TO  k 
IAOO=LNKSPC(IAOO) 

IF  ( IFLGSPC  (Ift  00)  . ANO.FL5HriO  ,NF  . 01  GO  TO  99 
GO  TO  1 

4 IFUFLGSPC(IAOO)  .ANO.FLOHSK)  •NF.OI  GO  TO  14 
ISTYPs (FLGSPC I IAOO) . ANO. FLG67) 

IFaTYP.FQ.S)  GO  TO  11 
IF  fISTYP.EQ.3)  1ST YPs2 
IF(ISTYP.NE.ITYP)  go  to  99 

II  IVALsLSTSPCIIAOO) 

IFUIPOS.NE.l)  .ANO.  (IPOS. NE. -1)1  GO  TO  99 
ITYPs (FLGSPCC IAOO) .AN0.FLG67) 

lstheo=-i 

RE  TURN 

14  LSTHtO=IAOO 
INO*0 

KN0EX=1  ABS  nsOFX) 

UPOS=IABS(IPOS) 

IF (NSKIP.EO.l)  GO  TO  50 

IF  ( (XFUNC.NF.  IFUNC) .OR . (KARG.NF. I ARG) ) GO  TO  50 
IF  ( (FLGSPCaST  HFO  ) . AN0.FL4MSK)  . NE  .0)  GO  TO  5C 
IF CCIPOS’INOFX) ,LF.O)  GO  TO  50 
IF  (JPOS.LT.  2)  GO  TO  50 
NOX*FLGSPC(INOXAO) 

IF ( (NOX. AN0.FL5MSK) .NE  .0)  GO  TO  50 
IF ( (NOX. ANO.FL IMSK) .FQ.O)  GO  TO  50 
IF(JPOS.GE.KNOEX)  GO  TO  25 
IF((JPOS»JPOS) .LE.KNOFX)  GO  TO  50 
IF(IPOS)  30*99.40 

50  FLGSPC (LSTHEO) *FL G$PC (LST HFO ) . A NO. NFL A G4 
IF(IPOS)  20.99.10 
C 

COUNT  DOWN  FPOH  TH-  TOP  OF  THE  LIST 
C 

10  IAOO  = LSTSPC(I  AOO) 

IF  ( (FLGSPC  (IAOO)  .AND. FLOMSK)  .NE.O)  GO  TO  99 
ISTYPs (FLGSPC i IAOO) . ANO. FLG67) 

IF (ITYP.EQ.3)  go  to  22 
IF(ISTYP.EQ.3) ISTYPs2 
IF  (ISTYP.NE.1 T VP)  GO  TO  10 
2?  IN0=IN0^1 

IF  (INO.NE. JPOS)  GO  TO  10 
20  IVAL=N00SPC(IA 00) 


I vri NO  2 
LVMNO  3 
L V P I NO  N 
L Y T I NO  ^ 

LVFInO  6 
LVFIND  7 
L V T I NO  8 
LVT^INO  9 
L vri NOlO 
LVFINOII 
LVFI N012 
LVFI NOl 3 
L V F I NO  1 4 
LVFI N015 
LVFI N016 
LVFIN017 
LVFiNOie 
LVFIN019 
LVFINO20 
LVFI N021 
LVFIN022 
LVFI N0?3 
LVFI N0?4 
LVFIN025 
LVFI N026 
LVFI N027 
LVFIN028 
LVFIN029 
LVFI NO30 
LVFIN031 
LVFI N032 
LVFI  N033 
LVFIN034 
LVFI N035 
LVFIN0  3F 
LVFI NO  37 
L VFI NO30 
LVFI N039 
LVFI NO40 
LVFIN041 
LVFI N042 
LVFI N043 
LVFIN044 
LVFI N045 
LVFIN046 
LVF1N047 
LVFIN048 
LVFIN049 
L VFI NO50 
LVFIN051 
LVFI N05? 

LVFIN053 

LVFIN054  i 

LVFIN055  I 

LVFINOSfc  I 

LVFIN057  I 

LVFIN058  J 


1 


ITrPs (FLCSPCr I AOO) .AN0.FLG6?) 

SS  INOE*sIPOS 
lNO«ftO*IADO 
<<FUNC=  lEUNC 
iTAPGs  I APG 
PE  TUPN 
C 

COUNT  UP  rPOM  TMf  ^OTTOH  OF  TME  LIST 
C 

?0  IAOO*LSTSPCnAOO) 
ifTFST'C 

?T  !AOOsl.^J<SPClIAOOI 

|k1EST,EO.O»  go  to  2k 

IF  MFLGSPCCLSTSPC  (MOOM  • a^C.FLOHSfO  . NE.  0)  GO  TO  90 
2k  KTFSI=l 

ISTTPs  KLCSPC  ( 1*00)  »AN0.PL06  7) 

IF  IITyp,E0,3)  GO  TO  21 
IF  (ISTYP.E0.3I  ISTvp  = 3 
IF(ISTYP.NE.ITYP)  go  to  23 
21  IN0=IN0^1 

IF(INO.NE.JPOS)  GO  TO  23 

29  IV*L=N0nSPC(I*00) 

IT  TPs (FLGSPC( 1*001 .*N0.FLG67) 

GO  TO  55 

25  IF(IPOS)  40,99,30 
C 

COUNT  OONN  FROH  IN0«*00 
C 

30  JPOSsI  ARSUPOS-KNOET) 

IAOOsINOXAO 

IF(JPO'‘.EQ.O)  GO.  TO  28 
GO  TO  10 
C 

COUNT  UP  FROM  INOXAOO 
C 

40  JPOS*IARS(JPOS-KNOEX) 

IAOOsINOXAO 

IFCJPOS.EQ.O)  GO  TO  29 
XTESTsl 
GO  TO  23 
99  IVALs-1 

INOEXcINOXAOsKFUNC«XAPG«0 

PE  TURN 

ENO 


LVFI N059 
LVFIN060 
LVFI N061 
LVFI N062 
LVFIN063 
LVFI N064 
LVPIN065 
LVFI N066 
LVFI N067 
LVFIN068 
LVFIN069 
LVFINO70 
LVFIN071 
LVFIN072 
LVFIN073 
LVFI h074 
LVFIN075 
LVFIN076 
LVFI N077 
LVFIN076 
LVFIN079 
LVFINDflO 
LVFI N081 
LVFI N082 
LVFIN083 
LVFIN084 
LVFI N085 

LVFI N086 

LVFI N0S7 
LVFI  N086 
LVFI N089 
LVFINO90 
LVFI N091 
LVFIN092 
LVFIN093 
LVFIN094 
LVFIN095 
LVF1N096 
LVFIN097 
LVFIN098 
LVFIN099 
LVFINlOfl 
LVFINIOI 
LVFIN102 


LVGRU  2 

LVG»L  3 
LVGPl  V 
LVGRL  5 
LVGRl  6 
LVGRL  7 
LVGRL  e 
LVGRL  9 
LVGRL  10 
LVGRL  11 
LVGRL  i? 
LVGRL  13 
LVGRL  1% 
LVGRl  15 
LVGRl  16 
LVGRL  17 
LVGRL  18 
LVGRL  19 
LVGRL  ?0 
LVGRL  21 
LVGRl  22 
LVGRL  23 
LVGRL  2** 
LVGRc  25 
LVGRl  26 
LVGRL  27 
LVGRL  28 
LVGRL  29 
LVGRL  30 
LVGRL  31 
LV'-RL  32 
LVGRl  33 
LVGRL  36 
LVGRL  35 


SU8R0UTINF  LVGRHfNOOE* 

INTfGEP  FLGSPC fRFGASP 

COHHON/L VVTR1/H£MSZE*RFCASP,W00SPC«  1) /L VV TR 2/L ST$PC < 11/ 

•LVVTR3/LNKSPC  « 1) /LWT  R4/FLGSPC  t 1) 

COMHON/LVPANO/  KPRIHE,lf5EF0,NR0K,K0M00E*  ICOROW,  IfTEMP 

NOOE-'(TE»1P^XONOOE 

KTEMPsNOOE 

KONOOE=*(ONOO=  ♦! 

IF(M00E.GT.HFHS2EI  go  to  5 

return 

C RESIDUE  generation  ? 

5 rECNRON.GT.KPRIMf I GO  TO  10 
NRQWrNROH^KSEEO 

IFINR0W,GT,KPRIHEI  NRON-NROM-KPPIHE 

NOOE=NROW 

<TEHP=NOOE 

<ONOOE*<PRI»€  ♦! 

C RESIDUE  GENERATION  ? 

IF (NODE*NE.KSEEOI  RETURN 
NROM=0 

KOROW*KPRIfC 
C RESIDUE  GENERATION 

to  VDROH*KOROW«l 
NPOM=NROW^<OROW 
NOOEsNROH 
VTEMpsNOOE 
KONOOEsKOROW 

IF  inode. GT.MEHS7EI  GO  TO  20 
RE  TURN 

20  PRINT  15 

15  FOPMATIIM  .•ERROR...  NUH8EP  OF  KOOES  EXCEEDS  REOUESTEO  Nf«ORY.*/* 
• PROGRAH  IS  Tf RMINATEO.*! 

STOP 

END 


SUP90UTINE  LVNSRT  L 

COMHON/L  VftRGS/ IFUNC* lARG, 1400* IPOS,IT YP2 ,IVAL*  LS^HED tNVAL • L 

♦ IOSTPY,IV4LS(10)  •ITYPUO)*N$KIP  L 

INTEGEP  FLGSPC  .FL0HSK,FLlMSK,FL2HS»C,FLi>NSK|FLG6r  ,PEGASPtTEMP,THIS*L 

♦ FL&TMP,TMO*TH(?EFtHEAO*OLOLOC,ASPREG,SEQSPC,FL  3HSK,FL4HSK  L 

COHMON/L VVTRI/H£MSZE*REGA$P,N00SPC(  1 1 /t V V TR 2/L STSPC  ( 11/  L 

•LVVTP3/LNKSPC  C 1) /L  V VT  R«*/F  UGSPC  < 1)  L 

COHMON/LVFL4G/FLOHSK,FL1MSK*FL?HSK,FL3HSK,  FL4HSiC*FL5HSK.FLG67  L 

COHHON  /LVTABL/  MAPSZEfHAPdl  /LVVSEQ/  I SEQSZ,  SEOSPC  (11  L 

DATA  TMO/Z*}/,  r HRE£/30/,NFLG6  7/3740/  L 

C L 

FLGThPsFLIHSK  L 

C L 

IF  (REGASP. EQ,  LSTSPC  (REGASP  »)  GO  TO  98  L 

C L 

C FORH  FIRST  WORD  OF  SINGLE  OR  HULTIVALUED  FUNCTION  L 

IFINVAL.EQ.DGO  to  20  L 

LSTTMPsREGASP  L 

FLGTMPs (FLGTMP.0R.FL2HSK)  L 

FLGTMPs (FLGTNP.OP.FLOHSKJ  l 

GO  TO  21  L 

20  LSTTnPsIVALS(I)  l 

21  FLGTMPt(FLGTHP,OR.ITYP(D)  l 

C L 

C L 

C-OETEPMINE  address  fop  function  l 

iaoo=ifunc*iarg  L 

if  CIAOO.GT.MEHSZEI  IAOO* IA00-HFMS7E  L 

C L 

c IF  THAT  ADDRESS  IS  ALREADY  IN  WORKING  SPACE*  GO  TO  25  L 

IF(I0STRY-ll  125*300*350  L 

125  IF((PL1HSK,ANO.FLGSPC(IAOO)I .NE.OI  go  to  25  L 

C L 

C UPDATE  REGASPIIF  NECESSARY)  L 

IFdAOD  .EQ.  REGASP)  REG  4 $P=LS  TSPC  ( I A 001  L 

C L 

C UPDATE  available  SPACE  L 

LSTSPC (NOOSPC ( IAOO) » »L  STSPC( IAOO)  L 

NOOSPC (LSTSPC ( 1400) I =N00SPC(I ADO)  L 

C L 

C INSERT  FUNCTION  L 

N0OSPC(I400)^IARG  L 

LSTSPC  (IA00)  = LSTTMP  L 

LNKSPC (1400)* I AOO  I 

C flag  u is  set  because  This  insertion  might  be  a recreation  of  an  l 

c old  list  l 

FLGSPC  (IA00)*FLGSPC(IA00)  .OR.FLGTmP.OR.FLNMSK,  0R.FL5MS*  L 

C L 

c insert  any  additional  function  values  l 

HfAO*TAOn  L 

OLOLOC  = IAOO  L 

IF(NVAL.GT.I)G0  to  50  I 

C I 

C IF  last  CELL  OF  AVAILABLE  SPACE  MAS  USED*  WRITE  MESSAGE  I 

IF  (PEGASP.EO. LSTSPC  IREGASP))  GO  TO  909  I 

IVAL*  TABS  I IVALSd  ) ) I 

return 


VNSRT  2 
VNSPT  3 
VNSRT  4 
VNSPT  5 
VNSPT  6 
VNSRT  7 
VNSPT  6 
VNSPT  9 
VNSPTID 
VNS  PTll 
VNSRT12 
VNSPT13 
VNSPT14 
VNSRT15 
VNSRT16 
VKSRT17 
VNSPT18 
.'NSRT19 
VNSRT20 
VNSPT21 
VNSRT22 
VNSRT23 
VNSPT24 
VNSPT25 
VNSRT26 
VNSRT27 
VNSRT28 
VNSPT29 

vnsrtto 

VNSRT  ? 
VNSffTJ? 
VNSPT33 
VNSRT34 
VNSRT  35 
VNSPT36 
VNSPT37 
VNSRT38 
VNSRT  39 
VNSPT40 
VNSRTwl 
VNSRT42 
VNSRT43 
VNSPT44 
VNSPT45 
VNSRT46 
VNSPT47 
VNSPT48 
VNSRT4.9 

vnsrtso 

VNSPT*  1 
VN5PT57 

V NS»T  3 
VNSPT  ‘ 4, 

V N<.  P T H 

^ P * » • 

V *r  • • • 
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DOC 
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r>  n 


C 

C If  that  AOOPESS  contains  TMF  HtAO  OF  A CONFLICT 
25  IFUFL5MS»(.AN0,FLGSPCIIA00))  .GT.OI  GO  TO  hi 
C 

C IF  that  AOOPESS  contains  a value  on  a HULTlVAtUE 
IFnFL2HSK.ANO.FLGSPClIAOOn  .GT.O.ANO.  (FLOHSK* 
•.0)  GO  TO  35 
C 

C 

C«THE  address  CONTAINS  A FUNCTION  ON  A CONFLICT  LIST 
THISsIAOO 
C 

C FIND  THE  PRECEDING  FUNCTION  ON  THE  CONFLICT  LIST 

26  IFCLNKSPCfL^SPC(TMlS)»*EO.IAOniGO  TO  27 
THISsLNICSPC(rHIS) 

GO  TO  26 

27  LASTsLNKSPCITHIS) 

NENL0C=REGASP 

IF <REGASP.€Q.LSTSPC (REGASP))  GO  TO  98 


LIST*  GO  TO  111 


UPDATE  AVAILA8LE  SPACf  AND  REGAS® 

LSTSPC (NODSPC I REGASPi ) *L STSPC ( RfCASP) 

NOOSPC  CLSTSP: « re  gasp) ) sNOOSPCf REGASP) 
REGASP=LSTSPC  (REGASPI 

HOVE  THE  FUNCTION  ON  A CONFLICT  LIST  TO  THE  FIRS 
NOOSPC (NENLOC) »NOOSPC  C I AOO I 
LSTSPC  (NENLOC)  *L  STSPC  ( I AOO) 

LNKSPC (NEWLOC) «L NKSPC ( lAOO) 

FLGSPC  (NENLOC)  sFLGSPCUAOD) 

FLGSPC (IAOO)=0 
LNKSPC (L  AST)  = MEML  OC 

INSERT  This  FUNCTION  AS  THE  HEAD  OF  A CONFLICT  L 
NOOSPC(TAOO)«IARG 
LNKSPCdAOOI^IAOO 
LSTSPC (IAOO)«LSTTHP 

FLGSPC (lAOO)sFLCSPC(IAOO) . OR* FlGT HP. OR •F L^HSK, 
IFMFLGSPC(NEtfLOC)*ANO.FLOHSK).EO*OI  GO  TO  3% 


30 


IF  THE  function  that  NAS  HOVEO  IS  THE  HEAD  OF  A NULTIVALUE 
NEXTsLSTSPCINENLOC) 

NEXT*LSTSPC(NEXT) 
lF(LSTSPC(NExn*NE«IAOO)GO  TO  30 
LSTSPC (NEXT) «NENLOC 


L VNSRT59 
LVNSRT60 
L VNS RT61 
LVNSPT62 

LIST,  GO  TO  35  LVNSRT63 

ANO, FLGSPC  (I AOO)  ) • EOL  VNSRT6I1 
LVNSRT65 
LVNSPT66 

I^VNSPT67 

♦BUT  NOT  THE  HEAD  OFLVNSRT68 
L VNSRT69 
LVNSRT70 
LVNSPT71 
L VNSRT72 
L VNSRT73 
LVNSRT74 
LVNSRT75 
L VNSRT76 
L VNSRT77 
LVNSRT78 
LVNSRT79 
L VNSPT80 
LVNSRT81 
LVNSRT82 
LVNSRT83 

T CELL  OF  available  LVNSRTSIi 
LVNSPT85 
L VNSRT56 
LVNSRT87 
L VNSRT88 
L VNSRT89 
LVNSRT90 
L VNSRT91 

1ST  LVNSRT92 

LVNSRT93 
LVNSRT94 
LVNSRT95 

0R.FL5HSN  LVNSRT96 

LVNSRT97 
L VNSRT98 
LIST.FIX  LVNSRT99 


C INSERT  ANY  ADDITIONAL  FUNCTION  VALUES 
3V  HEAOsIADO 
OLOLOCsIAOO 
IFINVAL.GT.DGO  TO  50 

IF <REGASP*EQ*LSTSPC (REGASP))  GO  TO  909 
IVAL  = IABSnVALSU)) 

RETURN 

C 

C- - - 

C-THE  address  CONTAINS  A VALUE  ON  A HULTIVALUE  LIST 
35  NEML0C*REGA$P 


LVNSPlOO 
LVNSRIOI 
LVNSRIO? 
LVNSR103 
LVNSR1Q4 
L VNSR105 
LVNSR106 
LVNSR107 
LVNSR108 
L VNSR109 
LVNSRllO 
L VNSRlll 
L VNSR112 
-LVNSR113 
LVNSR114 
LVNSR115 


8^) 


o o o ooo  r>  o o o r>  o 


i 


iriREGASP*EO*LSTSPClREGASPI)  GO  TO  98 

UPDATE  AVAILABLE  SPACE  AND  REGASP 

LSTSPC (NOOSP: (REGASP) » =L STSPC C RE  GASP) 

NOOSPC (LSTSPC ( REGASP) ) *NOOSPC ( REGASP) 

regasp=lstsp:  ( regasp) 

HOVE  THE  VALUE  ON  A HULTIVALUE  LIST  TO  THE  FIRST  CELL  OF  AVAILABLE 
NOOSPC (NEHLOC) «NOOSPC( lAOO) 


LSTSPC (NEWLOC) =L STSPC ( 1 AOO ) 

LNKSPC(NEMLOC) «L NKSPC ( I A 00 ) 

FLGSPC (NEMLOC) =FL GSPC ( I A 00 1 
FLGSPC (IAOO)=0 

: RESET  POINTERS 

LlsLSTSPC(NEHLOC) 

IF ( (FLOMSK.ANO.FLGSPC(L1 ) ) .EQ.Q)  GO  TO  200 
LN»(SPC(L  STSPC  ILl)  )*NENLOC 
GO  TO  201 

2C0  LNKSPC (Ll)*NEMLOC 

201  KZVAL=L STSPC (LNKSPC (NEHLOC)) 

IF((FLOSPC(K?VAL) •ANO»FLOMSK).NE«0)  GO  TO  38 
LSTSPC (LNKSPC (NEHLOC) )=NEHLOC 
GO  TO  39 

3B  LSTSPC IK7VAL)  sNEHLOC 
39  NOOSPC (IAOO)<IARG 

: INSERT  THIS  FUNCTION  AS  THE  HEAD  OF  A CONFLICT  LIST 

LNKSPC (IAOO)*I AOO 
LSTSPC(IAOO)=LSTTHP 

FLGSPC  <IAOO)*FLGSPC(IAOO) •0R.FLGTNP.0R.FL4MSK. 0R*FL5HSK 
IF  (REGASP. EQ.LSTSPC(REGASP))  GO  TO  909 
IVAL^IABSdVALSd)) 

RETURN 


-THE  ADDRESS  CONTAINS  THE  HEAD  OF  A CONFLICT  LIST 
111  THIS*IAOO 

IF  THE  FUNCTION  TO  BE  INSERTED  IS  NOT  ON  T )€  CONFLICT  LIST,  GO  TO 
A2  IF(NOOSPC(THIS).EQ,IARG)GO  TO  G3 

IF  MFLGSPC(LNKSPC  (THIS)  I .ANO.FLSHSK)  «NE.  01  GO  TO  60 
THIS=LNKSPC(THIS) 

GO  TO  42 

-THE  FUNCTION  TO  BE  INSERTED  IS  ON  THE  CONFLICT  LIST 
43  HEA0*THIS 

IFMFLCHSK.ANO.FLGSPCITHIS))  .E0,0)  GO  TO  51 
NFKT*L  STSPC  (THIS) 

OtOLOC  IS  THE  LOCATION  OF  THE  LAST  VALUE  ON  THE  HULTIVALUE  LIST 
OLOLOC*L NKSPC  (NEXT) 


-INSERT  ADDITIONAL  FUNCTION  VALUES 


LVNSR116 
L VNSR117 
LVNSR118 
LVNSR119 
LVNSP120 
LVNSR121 
LVNSR122 
SLVNSR123 
L VNSR124 
LVNSR125 
LVNSR126 
LVNSR127 
LVNSP128 
LVNSR129 
LVNSR130 
LVNSR131 
LVNSR132 
LVNSR133 
LVNSR134 
LVNSR135 
LVNSR136 
L VNSR137 
LVNSR138 
LVNSR139 
LVNSR140 
LVNSR141 
LVNSR142 
LVNSR143 
LVNSR144 
LVNSR145 
L VNSR146 
LVNSR147 
LVNSR148 
LVNSR149 
LVNSR150 
--LVNSR151 
LVNSR152 
LVNSR153 
LVNSR154 
60LVNSR155 
L VNSR156 
LVNSR157 
LVNSR158 
LVNSR159 
LVNSR160 
--LVNSR161 
LVNSR162 
LVNSR163 
LVNSR164 
LVNSR165 
LVNSR166 
LVNSR167 
LVNSR168 
LVNSR169 
LVNSR170 
--LVNSR171 
LVNSR172 


u o 


^ 


SO 

LSTASP'NOOSPC IREGASPl 

LVNSR173 

IN  = 0 

LVNSR176 

CO  TO  56 

LVNSR175 

c 

LVNSR176 

C-FOIJH  MULTIVALUE  LIST  TO  AOO  VALUE(S»  TO  SINGLE-VALUED  FUNCTION 

LVNSR178 

51 

IN=0 

LVNSR179 

IFIRECASP.EO.LSTSPCIRECASPMGO  to  98 

LVNSR180 

1 

LSTASP=NOOSPI  (REGASP) 

LVNSR181 

NEWL  OC*RE6ASO 

L VNSP182 

1 

REGASP=LSTSPC  ( REGASP) 

LVNSR183 

NOOSPC (NEMLOC) =LSTSPC (THIS) 

LVNSR184 

TEMPS  C EL  GSPCf  THIS). AND .EL G67) 

LVNSR185 

flgspc  (nehloc)  =(Temp.or.flgspc(nenloc)  ) 

LVNSR186 

' 

FLGSPC  (TMIS)=  ( FLGSPC  (THIS)  .ANO.  NFLG6T ) 

LVNSR187 

ELGSPC  <THIS)«  IEL2MSK.0R.ELGSPC  (THIS)) 

LVNSR188 

FLGSPC  (THIS)  = (FLO  HSK.OR.  FLGSPC  (THIS)) 

LVNSR189 

ololoc=this 

LVNSR190 

c 

LVNSR191 

C INSERT  ANOTHER  VALUE  ON  MULTIVALUE  LIST 

LVNSR193 

5^ 

FLGSPC  (NEHLOC)  = (FL2HSK.OR.FLGSPC( NEHLOC)  ) 

LVNSR194 

ELGSPC INEHLOC) = < F LIMSK . OR . EL GS PC < NEML OC) ) 

LVNSR195 

LSTSPC  fOLOLOC) *NEMLOC 

LVNSR196 

LNKSPC(NEMLOC) =OLOLOC 

LVNSR197 

OLOLOC'NEHLOC 

LVNSR198 

56 

NEMLOC=REGASP 

LVNSR199 

IF(IN.GT.O)GO  TO  57 

LVNSR200 

C 

LVNSR2C1 

C NO  VALUES  HAVE  SEEN  INSERTED  VET 

LVNSR202 

IN  = 1 

LVNSR203 

GO  TO  58 

LVNSR204 

1 C 

LVNSR205 

‘ C SOME  VALUES  HAVE  BEEN  INSERTED 

LVNSR206 

5 7 

lEIIN.EQ.NVALI  GO  TO  67 

LVNSR207 

INsIN^l 

LVNSR208 

C 

LVNS  R209 

58 

IE(REGASP.EO.LSTSPC(REGASPM  GO  TO  909 

LVNSR210 

PEGASPsLSTSPC  (RECASP) 

LVNSR211 

NOOSPC  (NENLOC  ) *IVALS  (IN) 

LVNSR212 

flgsponehloc)  »(ityp(in)  .or.flgspc(nehloo) 

LVNSR213 

GO  TO  57 

LVNSP214 

c 

LVNSRZ15 

1 C ENO  MULTIVALUE  LIST  AMO  UPDATE  AVAILABLE  SPACE 

LVNSR216 

67 

LSTSPC  (OLOLX)  =HEAO 

LVNSR217 

NOOSPC (REGASP) sLSTASP 

LVNSR218 

LSTSPC(LSTASP)  sREGASP 

LVNSR219 

ival=iaps(ivals(D) 

LVNSR220 

LNKSPC  (LSTSPC  ( HE  AO) ) =OLOLOC 

LVNSR221 

NVAL-IN 

LVNSR222 

IF(REGASP.EQ.LSTSPC(REGASP))  GO  TO  909 

L VNSR223 

RETURN 

L VNSR226 

c 

LVNSR225 

C-TME 

FUNCTION  TO  9E  INSERTED  IS  NOT  ON  THE  CONFLICT  LIST 

LVNSR227 

60 

ASPREGsREGASP 

LVNSR228 

LSTASP=NOOSPC (PEGASP) 

LVNSR2Z9 

91 

L i 


o o 


IF  fREGASP.C0«LST5PC(9eGASPM  GO  TO  98 
C 

C UPDATE  AVAILAaE  SPACE  AND  REGASP 

LSTSPC  INOOSPC  CREGASPI I »LSTSPC<REGASPI 
NOOSPC  aSTSPC  IREGASPI  » =NOOSPC  C RE  GASP ) 

PEGASP«LSTSPC  (REGASPI 

INSERT  FUNCTION  IN  FIRST  CELL  OF  AVAILABLE  SPACE 
NOOSPC  f ASPRCGI sIARG 
IFtNVAL.EO.DGO  TO  611 
LSTSPC (ASPREGI =REGASP 

flGSPC  USPREGI  *CFL2HSK.0R.FLGSPC  CASPREGI  I 
FLGSPC  CASPREG) s |FLOHSK«OR*FLGSPC  CASPREG» I 
GO  TO  61? 

611  LSTSPC (ASPREGI sIVALSCll 

61?  FLGSPC (ASPREG) «FLGSPCfASPREGI*OR.ITYPfl) «OR • FL INSK. OR* FL4KSK 
LNI^SPC  USPREGI  =LNKSPCC THIS! 

LNKSPC ITMISIsASPPEG 
IF(NVAL.EQ*HG0  to  613 

c 

C INSERT  ADDITIONAL  VALUES 
LSTASP*NOOSPC  f RE GASP I 
OLOLOC^ASPREG 
HEA0«ASPREG 
IN*0 
GO  TO 

6lT  T^lRfGA^P.Eo.LSTSPCIREGASPn  CO  TO  909 
tVAL^I ABS  f IVALSC 1 1 1 
PE  TURN 

r 

c ncsTPucTive  imseption 
c 

1‘0  tAOOl«IAOO 
INOEW-C 

CALL  L VF IMOIINOE V* INOEY* INOE Y, fNOEYI 
FLGSPC  llAOOI*FLGSPCaAOOI  .OR.FtVNSY 
IF  MVAl,EQ*-1I  GO  TO  90 
IFUSTMfOl  90,356 

1S4,  iSTSPCUAOOIMVALSm 
GO  TO  365 

T56  NOOSPC  eiADOMIVALSCll 

36 5 FlG*‘PC  II  AOOIsFLGSPCT  IAOOI  • AND.  NFL  G6? 

FLGSPC  11  AOO)sFLG*^PC  1 1 ADO  I .OR.ITYPII) 

GO  TO  36  0 

BO  IF  IIP0S»9l,99,9? 

91  IPOS*IPOSFl 
GO  TO  93 
9?  IPOS*IPOS-l 
93  lAOOsIAOOl 

IF IIPOS.EO*0>  GO  TO  1?5 
lNOfif*0 

call  L VF INO CI NOEY.INOEY, INOEY.INOEY) 

IF  I tVAl •EQ.-ll  GO  TO  99 
IF  UPOS.LT.OI  go  TO  370 
lAOOsIAOni 
GO  TO  l?5 

3?0  nenloc*regasp 


LVNSR230 
LVNSR231 
LVNSR23? 
LVNSR233 
LVNSR?34 
LVNSR235 
LVNSR236 
LVNSR237 
LVNSR230 
LVNSR239 
L VNSR240 
LVNSR241 
LVNSR24? 
LVNSR243 
LVNSR244 
LVNSR245 
LVNSR246 
L VNSR247 
LVNSR248 
L VNSR249 
LVNSR250 
LVNSR251 
L VNSR252 
L VNSR253 
LVNSR254 
LVNSR255 
L VNSR256 
LVNSR257 
LVNSR258 
LVNSR259 
LVNSR26Q 
LVNSR261 
L VNSR262 
L VNSR263 
LVNSR264 
L VNSR265 
LVNSR266 
LVNSR267 
L VNSR268 
LVNSR269 
LVNSR270 
L VNSR271 
L VNSR272 
L VNSR273 
L VNSR274 
LVNSR275 
L VNSR276 
LVNSR277 
LVNSR278 
LVNSR279 
I VNSR260 
LVNSR281 
LVNSR282 
LVNSR283 
L VNSR284 
LVNSR285 
LVNSR286 


o o n 


IFILSTHeO)  325,95,375 

LVNSR287 

c 

UPDATE  AVAILABLE  SPACE 

L VNSR206 

LSTSPC  CNOOSPC  C RE GASP) ) =L S TSPC 1 RE  GASP) 

L VNSR2S9 

NOOSPC  CLSTSPC (REGASP)) «NOOSPC ( RE GASP) 

LVNSR290 

REGASP=LSTSPC  CREGASP) 

LVNSR291 

C 

GO  TO  377 

L VNSR292 
LVNSR293 

C 

C 

nondestructive  insertion 

LVNSR294 

LVNSR295 

30  0 

IAODl= lAOD 

LVNSR296 

NE  WLOC'REGASo 

LVNSR297 

INOEXxC 

LVNSR290 

CALL  LVF  I NO  II  NOE*,  INDEX,  INDEX,  INDEX) 

L VNSR299 

FLGSPC  IIAOO)  = rLGSPCaAnO)  .0R.EL4MSX 

LVNSR300 

IMIVAL,EQ.-l)  GO  TO  90 

LVNSR301 

IF(LSTHEO)  344,90,346 

LVNSR302 

344 

IF(IPOS.GT.O)  GO  TO  325 

LVNSR333 

IA00=IA001 

LVNSR304 

GO  TO  125 

LVNSR305 

C 

CREATE  HULTIVALUE  LIST 

L VNSR306 

325 

LSTSPC  1 NOOSPC  CREGASP)) »LSTSPCI REGASP) 

LVNSR307 

NOOSPC  CLSTSp:  CRE'GASP)  ) sNOOSPC  CREGASP) 

LVNSR308 

REGA5P*LSTSPC  C REGASP) 

LVNSR309 

IFCRECASP.EQ.LSTSPCCREGASP))  go  to  909 

LVNSR310 

NNL0C2*REGASP 

LVNSR311 

C 

UPDATE  available  SPACE 

LVNSR312 

LSTSPC  CNOOSPC  CREGASP) ) «L STSPC C REGASP) 

LVNSR313 

NOOSPC CLSTSPC  CREGASP) )*NOOSPCC  REGASP) 

LVNSR314 

REGASP«LSTSPC  CREGASP) 

LVNSR315 

NOOSPC CNEWLOC) sIVALSCl) 

LVNSR316 

LSTSPC  CNEWLOC) *NMlOC2 

L VNSP317 

LNXSPC  CNEWLOC) *NWLOC2 

LVNSR318 

FLGSPC  (NEWLX)  *FLGTHP,0R.FL2HSK 

LVNSR319 

NOOSPC  CNWLOC2) *LSTSPCf lAOO) 

LVNSR320 

LSTSPC  CNWLOC2) «IAOO 

LVNSR321 

LNXSFC  CNWLOC?)  «NEWLOC 

LVNSR322 

KLGTEP*FLG$PC  ( IAOO)  ,AN0.FLG67 

LVNSR323 

FLGSPC  CNWLOC?) = 1 F LIHSX. OR, FL2HSK ) .OR.KLGTEP 

L VNSR324 

LSTSPCCIAOO)»NEWLOC 

LVNSR325 

FL  GSPC  Cl  AOD)s  C FLGSPC  (IAOO)  .OR,  FLO  NSW)  ,OR«FL2HSk 

LVNSR326 

320 

IFCRECASP.EQ.LSTSPCCREGASP))  GO  TO  909 

LVNSR327 

36  0 

IVALxIABSCtVALSCDI 

LVNSR328 

RETURN 

LVNSR329 

C 

IPOATE  available  SPACE 

LVNSR330 

346 

LSTSPC  CNOOSPC  CREGASP)) «LSTSPC (REGASP) 

LVNSR331 

NOOSPC (LSTSPC (REGASP) ) <NOOSPC ( REGASP) 

LVNSR33? 

RECASP«LSTSPC(REGASP) 

LVNSR333 

IFCIPOS.lt. 0)  GO  TO  347 

LVNSR334 

377 

ISTLPC»LNWSPC(IAOO) 

L VNSR335 

NOOSPC  CNEWLOC) xIVALSCl ) 

LVNSR336 

LSTSPC  CNEWLOC)  «lAOO 

LVNSR337 

LNXSPC  CNEWLX)  xISTLOC 

L VNSR338 

FLGSPC  CNEWLOC) ■FLCTMP.OR.FL2MSK 

L VNSR339 

IFCCFLGSPCCLSTSPC (ISTLOC) ) .ANO.FLOHSK) .EO.O)  GOTO  3?1 

L VNSR340 

LSTSPC (LSTSPC ( ISTLOC ) ) *NE WLOC 

LVNSR341 

GO  TO  322 

LVNSR342 

321 

LSTSPC  C ISTLOC  ) *NE  WLOC 

L VNSR343 

‘I  ( 


I 


3?2  LNKSPC  (laoOl^NEWUOC 

L VNSR344 

GO  TO  3?0 

LVNSR34$ 

347  NOnSPC tNeWLOC) *I VftLSfl > 

L VNSR34E 

LSTSPC INENLOC)  =LSTSPC < lAOO) 

L VNSP347 

LNKSPC  <NEWLOC1  =1400 

LVNSR34B 

fLGSPC  (NCWLOC»  =rCGTMP,  OP.FL^MS•C 

L VNSR349 

IF ( CFLGSPC (LSTSPC  Cl 400) ) . 4N0.FL0MSKl.EQ, 0) 

GO 

TO  333 

LVNSP350 

KZV4L  = LSTSPC« I 400) 

LVNSR351 

LNKSPC  (LSTSPC  (KZV4L)  ) sNFMLOC 

LVNSR353 

GO  TO  3?4 

LVNSR353 

3?T  LNKSPC  (LSTSPC  ( 1400)  )*NEWLOC 

LVNSP3S4 

3?4  LSTSPC (I400)=NEML0C 

L VNSR355 

GO  TO  330 

LVNSR356 

99  IV4L=-3 

LVNSR357 

PRINT  30001 

LVNSP358 

3000  1 FOPM4T(  • ERROR,  • .THERE  IS  NO  400ITION4L 

SPACE  FOR  THE  GRAPH, 

THELVNSR359 

• PROCR4H  IS  TERHINATEO*) 

LVNSR360 

STOP 

LVNSR361 

99  IV4L=-1 

L VNSR363 

??  F0RM4T(1X,I5,IH(,I5,35M>  USEO  L4ST  CELL  OF 

AVAILABLE  SPACE) 

LVNSP363 

RE  TURN 

LVNSP364 

SOS  PRINT  ?3, IFUNC , I4RG 

LVNSR365 

C this  insertion  has  filled  GIRS  HEHORT  - CALL  A 

USER  SUPPLIED 

L VNSR366 

C PROGRAM  - LVEXIT, 

LVNSR367 

IV4L=-1 

LVKSR368 

return 

LVNSR369 

ENO 

LVNSR370 

10 


SUnPOUTINE  L^SETP 

INTEGEP  FLGSPCtEL»GSP,REG»SP,f»INFIL,FL0HSK,FLlMSKtEL2HSK,FL5MSIt, 

♦ Fl3NSF.FLi.HSKtFL&67,SEQSPC 

COM«ON/L»FI»G/FLOMSF,FL1HSK,  FL0MSlt,FL3HSK,Ftl.HW.FI.SHSK,FLG67 
COHHON/L  VVTP5/8INFILtt(OMP»N,NOOESPIl)  /LVWTR6/L  ISTSP(l) 

♦ /LVVTP771.INFSP(  lt/LVVTR8/FL»GSPtl) 

COHHON  /LVT»8L/  M»PS7EtH»P(ll  /EVVSE07  I SEQS  7,  SE  OSPC « II 
rOMHON/L»VTRl/MEHSZE,REG»SPtNO')SPC«  1» /I  VVTR  2/LSTSPC  ( 11/ 

•tVVTP3/LXIfSPCI  l»/lVVT9*/FEGSPCt  H 
COMHON/L  VPAMO/  KPRIME  , KSEEOt  NROR,  KDNOOE.  FOROM.  FTFMP 
DATA  FLOMSK/20  0B/.FL1HSK/I00e/,FL2HSK/I»0  B/,FL5HSF/i.B/,FlG67/3B/t 

♦ Fl3HSF/20B/,Fl4MSF/iaB/ 

KSFEO=FPRIPE/2 
NR0*I*FEFE0 
FTEHP^KSEEn-FPRtME 
KONOOE  = KPRIHE 
REGASP^l 

no  10  i*z,hehs7e 

lNK$PC<It>0 

FLGSPC (I**0 

NOOSPCIIMI-l 

LSTSPC  IT-1)«I 

FLGSPcm«o 

I.NKSPC  (11*0 

N00SPC»1MBEMS7E 

LSTSPC (BEMS7EI *1 

RETURN 

FNO 


LVSETP  2 
LVSETP  3 
LVSETP  4 
LVSETP  5 
LVSETP  6 
LVSETP  7 
LVSETP  8 
LVSETP  9 
LVSETPIO 
LVSETPll 
LVSE  TP12 
LVSETP13 
LVSETP14 
LVSETP15 
LVSETP16 
LVSETP17 
LVSETP18 
LVSFTP19 
LVSETP20 
LVSETP21 
LVSETP22 
LVSETP23 
LVSETP24 
LVSETP25 
LVSETP26 
LVSFTP27 
LVSETP28 
L VSFTP29 


SUPffOUTINe  HOOrOfWOOFI 
OlHtMSIO»<  lBUriSC>«I£N0(3l 
ir (HOOr  .NE.  01  GO  TO  6 
NPITE 

1 FORMAT  <5Jr,l6H  OUTPUT  DEVICE 
WRITEI14*2I 

^ FORMAT <5X,16H  OUTPUT  OtVICE  T» 

WRITE  C15,3I 

3 FORMAT <5X,16H  OUTPUT  DEVICE  7> 

WRIT- (f .6) 

6 FORMAT  aHl,5?X,?7H  RESULTS  OF  ROLL  CALL  CMFCK) 

5 DO  10  IslOtl? 

ENOFILF  I 

REWIND  I 

RE  AO  Cl, 7 I I char 

7 FORMATCAIJ 

10  IEN0(I-9I=E0FCI> 

IEOF*0 
DO  15  1=1,3 

IFCIENDCn  .NE.  C>  GO  TO  15 
IF  I lEOF  .EO.  1)  GOTO  40 
IE  OF*  1 
I0UT=9*I 
15  CONTINUE 

IFCHOF  ,EQ,  01  GO  TO  50 
REWIND  lOUT 
lOUTEs IOUT»3 
WR  IT-  C IOUT^,^0  > MODE 
?0  FORMAT C//20X, I 2H  MODE  INDEX*, IT) 

DO  3C  1=1,100 

RE  AO  Cl  OUT, 25)  CIPUFCJ) ,Jsi,SQ1 
25  FORMAT  CSOAl) 

IFCEOFCIOUT)  ,NE.  0)  GO  TO  60 
30  WRlT£CIOUT2*25)  ( IBUF C J) , J = 1 , 8 0 I 
40  WRITEC6,45)  MODE 

45  FORMAT I//21X, 86H  •♦ERROR  IN  ROLL  CALL  CMECK  - MORE  THAN  1 OUTPUT  0 
•EVICE  WAS  WRITTEN  ON  FOR  MODE  INDEX  ,I3,2M**) 

GO  TO  60 

53  WRIT:Ct,55l  iOOE 

55  FORMAT C//25X, 79H  ••ERROR  IN  ROLL  CALL  CHECK  - NO  OUTPUT  DEVICES  WE 
•RE  WRITTEN  ON  FOR  MODE  INDEX  ,I3,2H^^) 


63  REWIND 

10 

REWIND 

11 

REWIND 

t? 

RETURN 

END 

FUNCTION  NEXTIIkt 

NEXT 

Z 

COmON  .OI$OOI,  lOTBLia.SOOl.INlTlDISI  ,L«STIDI3I  .ISRCHI3I, 

RICH 

Z 

• JPTR.N.N,  JTTP,|.ST*RT,N7,  IFNCNN.LOGIOiNXTIO.IOTVP.NIDtLOCt 

CV58A 

81 

2 LTYP.ITYP.IBLKOT.HOOEtlERR.IOES 

RICH 

% 

INTEGER  a. BLANK 

NEXT 

k 

DAT*  BLANK/tH  / 

NEXT 

$ 

C»»  THIS  FUNCTION  RETURNS  TMR  NEXT  NON-BLANK  CHARACTER  IN  THE 

NFXT 

6 

C»»  INPUT  STREAH 

NEXT 

r 

IFIIA  .GT.  NT  GO  TO  IB 

NEXT 

8 

00  10  I«IA,N 

NEXT 

9 

IFIA«I)  .EQ.  BLANK)  GO  TO  10 

NEXT 

18 

C»»  “A«D-  IS  THE  NEXT  CHARACTER 

NEXT 

11 

NEXT>A  (I) 

NEXT 

12 

JPTR«I«1 

NEXT 

13 

RETURN 

NFXT 

19 

10  CONTINUE 

NEXT 

1$ 

)CXTiBLANK 

CX55 

1 

C»»  NO  MORE  CHARACTERS  IN  STRING 

NEXT 

17 

JPTR=N*1 

NEXT 

18 

RETURN 

NEXT 

19 

15  NEXTiBLANK 

CT55 

2 

JPTR«IA»1 

CY55 

3 

RETURN 

CV55 

9 

END 

NFXT 

20 

FUNCTION  NXTBLKIILOCtlENO) 

NXTBLK 

2 

COHHON/BASBLK/IBLOCKI  75001  .NBLOCK.NB.NBRNCH 

CY58A 

51 

COHHON/LABELS/STATRA<7,700I,NLA6EL 

NXTBLK 

9 

INTEGER  STATRA .BITGET 

NXTBLK 

5 

C** 

THIS  ROUTINE  RETURNS  THE  STARTING  LOCATION  OF  THE  BASIC 

BLOCK 

NXTBLK 

6 

C** 

NHICH  A BRANCH  POINTS  TO 

NXTBLK 

7 

C** 

ILOC  - BASIC  BLOCK  TABLE  LOCATION  OF  BRANCH 

NXTBLK 

8 

C** 

IE  NO  - EM)  OF  CURRENT  BLOCK 

NXTBLK 

9 

I>IBLOCKIILOC) 

NXTBLK 

to 

IFCI  .EQ.  9B9)  GO  TO  10 

NXTBLK 

11 

IF  II  .EQ.  99B)  GO  TO  5 

NXTBLK 

12 

c** 

BRANCH  IS  A STATENENT  LABEL  - RETRIEVE  BASIC  BLOCK  START 

FROH 

NXTBLK 

13 

c** 

THE  STATENENT  NUNBER  TABLE 

NXTBLK 

19 

NXTBLK^BITGET 1ST ATRAI 7.1) .36.18) 

NXTBLK 

15 

RETURN 

NXTBLK 

16 

c*» 

BRANCH  IS  TO  NEXT  BASIC  BLOCK  IN  TABLE 

NXTBLK 

17 

5 NXTBLK«IENO*l 

NXTBLK 

18 

IFInxTSLK  .GT.  NBLOCK)  CALL  ERR0RI38) 

NXTBLK 

19 

RETURN 

NXTBLK 

28 

return  or  STOP  - END  OF  PATH 

NXTBLK 

21 

10  NXTBLK*0 

NXTBLK 

22 

RETURN 

NXTBLK 

23 

END 

NXTBLK 

29 

FORTRAN  Version 


subroutine  p»rse  parse 

COHHON/LVARGS/LVEUNCtLVV*RG,LVV«OtLV¥POS  .LVVTYP,  LYWALi 

♦ IVHEAD.LVVNVL.LVOEST.LVVAISI  10 ) , L VTTPE  1 1 0)  ,L  VS  « P 

CONMON/LVTABL/LVTSII,LVMAP(  1 1 /L  VVSEQ /L  VS  II  E,  LVSQSP  1 II 

COMMON/NEEOS/STJ, JSTACK.R.JAS, J, JLAST.RTENP, stack  140 01  PARSE 

COMMON/FUNC/  NARY(5,12I ,HARGS, IARGSI50) .FMCLOCISI ,NFUNC  CY58B 

COMMON  /STRING/  NTYPE . NS TR ,STR  PARSE 

COMMON  /GIRL/NTERMS.  PLUS  t MINUS,  SLASH,  L par,  RPIR  ,C  OMNA  , S TAR,EXP,  LT  , PARSE 

«LE,GT,GE,Ea,NE,OR,ANO,NOT,EOUALS,OPRANO  PARSE 

COMMON  /HL/  HOL, ACTION, FUNC1,FUNC2,FUNC3,LEFT, RIGHT, STRING, NAXJ  PARSE 

COMMON  /NEED/  START, ASSOC, LEVEL, STOP  PARSE 

COMMON  /TYP/  NARRAY,TYPE1,TYPE2,ERRFLG  PARSE 

COMMON/NOPAR/NOPAR,NOEP, NOEPTH,NELAG  PARSE 

COMMON  /NTIMES/  NTINES,!  PARSE 

COMMON/VAR/VFORC  15)  ,NUNCHR,NCH  tP,CHAR,  NOICT  CY5SB 

INTEGER  TYPEl,TYPE2, START, TYP(3)  PARSE 

LOGICAL  ERRFLG,FAIL  PARSE 

INTEGER  STRCll  ,STEMP,ST,OICT(l<n  PARSE 

eouivalenceioict(i),plusi  parse 

INTEGER  PLUS, M INUS, SL ASM, LPAR,RPAR, COMMA ,STAR, EXP,LT,LE,GT,GE,EO,  PARSE 

♦ NE, OR, AND, NOT, EQUALS, OPR  AND, ASSOC, LEVEL#  STOP, ACT  ION, HOL, LEFT, RIGHT PARSE 

♦,strinc,funci,func2,func3  parse 

DATA  NTINES  /O/  PARSE 

IFINTIMES  .CT.  0)  GO  TO  3 PARSE 

NTIMES=l  PARSE 

GO  TO  25000 
25001  CONTINUE 

CALL  PHONEY  PARSE 

CALL  LVFECHI19I  PARSE 

REA0I19IPLUS,  MINUS, SLASH, LPAR,RPAR, COMMA  ,STAR,  EXP,LT  ,LE ,GT ,6E,E0,  PARSE 

♦ NE, OR, AND, NOT,  EQUALS, OPR ANO, ASSOC, LEVEL,  STOP , A CT  ION, HOL, LEFT, RIGHT PARSE 

Y, STRING, FUNC1,FUNC2,FUNC3,NTERNS,(TYP(I)  ,Isl,3l  PARSE 

3 IFINSTR  ,LE.  0)  RETURN  PARSE 

ERRFLG,. FALSE.  PARSE 

START»TYP(NTYPE)  PARSE 

NARGS'O  PARSE 

NFLAG^O  PARSE 

MAXJ«0  PARSE 

NOPAR>0  PARSE 

TYPE1«-1  PARSE 

TYPE2*-1  PARSE 

NARRAY«-1  PARSE 

NOEPTHsO  PARSE 

NOEP'O  PARSE 

00  20  I>1,50  PARSE 

20  IARGSCI)>0  PARSE 

00  22  1^:1, 60  PARSE 

22  NARYIII>0  PARSE 

00  10  I>1,NSTR  parse 

LVl  AAB  • STRING 

LVVPOS  « I 

LVVTYP  • 3 

LVFUNC>  HOL 

LVVARG*  LVl  AAB 

CALL  LVFIN0ILV2  A,LV2  B.LV2  C.LV2  01 

LVl  AAC  • LVl  AAB 

IF  ILVVAL.NE. -II  LVl  AAC  • LVVAL 


2 


3 

1 

5 

6 

7 

8 
9 

10 

11 

12 

2 

14 

15 

16 

17 

18 

19 

20 
22 

23 

24 


26 

27 

28 

29 

30 

31 

32 

33 

34 

35 

36 

37 

38 

39 

40 

41 

42 

43 

44 

45 

46 

47 


AAC 


NTFHP  = LVl 
LVVTR  = LVVAL 
LVVAL  = -100 
IF  aVVT«,NE.-l)  GO  TO 
CALL  LVr.RNILVl  AAC) 

LVOESTs  0 
LVTYPEIl)  = 0 

LVVALS(l)  s LVl  AAC 

LVVNVL  » 1 

LVFUNC  « MOL 

LVVAPG=LV1  AAB 
CALL  LVNSRT 

IF(LVVAL,LT,0)  call  LVEXITaVVAD 
IF CLVVAL.LT .0 ) RETURN 

NTEHP  = LVl  AAC 
4 CONTINUE 

IF(ERRFLG)  GO  TO  25 
ST*IABSlSTRm  ) 

IFISTRII)  ,lT,  0)  GO  TO  6 

LVOESTs  0 

LVl  AAB  s ST 
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37 

10 

CONTINUE 

PRNTS 

36 

NC*l«fNC HARP-1  I/O 

PRNTS 

39 

10  0 

FORMAT (1X,15A0) 

PRNTS 

46 

IFIERRFLGI  PRINT  100  • C VFOR  CII  « I«  1 ,NC» 

PRNTS 

41 

G 

complete 

PRNTS 

42 

j 

I 

j 

1 


SUBROUTINE  PROG 

PROG 

2 

COMMON  A 11326) «D 1 500 ) « lOTBL C 6* 500 1 t IN  I TI 0 f 3) ,L  ASTTO ( 3 » « ISRCH 1 3 I « 

RICH 

2 

* JPTR«N,M» JTYP,LSTART«N2, IFNCNHfLOGIOf NXTIOt 10 TYP« NIO »LOC « 

CV5  6A 

60 

2 LTYP, 1TTP*IBLX0T,H00E«IERR«I0ES 

RICH 

4 

OlfCNSION  IALPHC7I 

PROG 

4 

DATA  IIALPHII) t I« 1 t 7) / IMP, IHR, IHO « IHG « 1H R, 1H A« IHM/ 

PROG 

5 

PROGRAM  STATEMENT  PROCESSOR 

PROG 

6 

JPTR*7 

PROG 

7 

CHECK  SPELLING 

PROG 

6 

00  5 I*l,7 

PROG 

9 

IFCNEXTCJPTR)  .NE.  lALPH(II)  GO  TO  10 

PROG 

10 

5 CONTINUE 

PROG 

11 

GET  PROGRAM  NAME  ANO  STORE  IN  SYMBOL  TABLE 

PROG 

12 

CALL  GNLE 

PROG 

13 

IFUTYP  .NE.  2)  GO  TO  10 

PROG 

14 

IOTVP-2 

PROG 

15 

CALL  STORE 

PROG 

16 

RETURN 

PROG 

17 

10  CALL  ERROR(7) 

PROG 

16 

RETURN 

PROG 

19 

END 

PROG 

20 

107 


REAL  FJNCTION  QIREALIX) 

DATA  R/7T777777777T7kQQQ0QQ%/ 

QIRE  AL<  ANQUf  Rl 

RE  rUKR 

END 

DOUBLE  PRECISION  FUNCTION  QIOPRE I XI 

DOUBLE  PRECISION  X,T 

OIHENSION  M<a> 

equivalence  IT, H(1 M 

DATA  R/  7 77  7777777  7 77t*00Q0QQd/ 

T=X 

Hli|sANO<Nfll«R) 

Hiai  >AN0MI3I  ,RI 

Q10PRE=T 

RETURN 

ENO 

complex  FUNCTION  QiCOMPIXI 

COMPLEX  X,T 

DIMENSION  MI2) 

equivalence  IT, Nil  II 

DATA  R/ 7777777777777hQQQQQ0B/ 

T«X 

WIllsANOlWlllfR) 

M(2I:AN0(N(2I,RI 
QlCOMPsT 
RE  TURN 
tNO 


39  Bits 


REAL  FUNCTION  QlREALIXI 

DATA  R/77777777777770000000B/ 

QlREALsANOIXfRI 

RETURN 

ENO 

DOUBLE  PRECISION  FUNCTION  QIOPRE IX) 
DOUBLE  PRECISION  X,T 
DIMENSION  W(^} 

EQUlVALENCEIT.Nlin 

DATA  R/777777777777700000009/ 

T = X 

H(l)=ANO(MCll,RI 
MI^)sANO(N(^l•RI 
QIOPRE*  T 
RE  TURN 
ENO 

COMPLEX  FUNCTION  QiCOMPIXI 
COMPLEX  X,T 
DIMENSION  WI2) 

equivalence  it, Nil  I) 

DATA  R/7777777777777000000J9/ 

T = X 

Min-ANOINClItR) 

M(^l=ANOIMI2),R| 

Q1C0MP=T 
RE  TURN 
ENO 


38  Bits 


REAL  FJNCUOH  QlREALCXI 

DATA  R/777777777777hQQQQQQQ3/ 

Q1REAL>AN0(X«R) 

RETURN 

END 

DOUBLE  PRECISION  FUNCTION  QIOPRECX) 

DOUBLE  PRECISION  X,T 

OlHENSION  W(2I 

EQUlVALENC£(T,WCin 

DATA  R/777777777777600000000/ 

T = X 

wm=ANO(Ha>,R) 

H<21=AN0IM(2),R) 

QlOPREsT 

RETURN 

END 

COMPLEX  FUNCTION  QICOMPCX) 

COMPLEX  X«T 
DIMENSION  UI2) 

EQUIVALENCE  CT«H(1 M 

DATA  R/7777777777776OOOOOOO0/ 

T = X 

N(1):AN0(W4U«R) 

HI2MAND(M(2)tR) 

QlCOMPsT 

RETURN 

END 


37  Bits 


REAL  FUNCTION  QlREALfX) 

DATA  R/777777777777400000000/ 
QlREALsANOCXf R) 

RETURN 

END 

DOUBLE  PRECISION  FUNCTION  QlDPRECXl 
DOUBLE  PRECISION  X«T 
DIMENSION  U(2) 
equivalence  (TtWIl  )» 

DATA  R/77777777777740000000B/ 

T*X 

H(1):AND(N(1)«R) 

W(2|:ANO  CHC2I ,R» 

Q1DPRE*T 

RETURN 

END 

COMPLEX  FUNCTION  QICOHP(X) 

COMPLEX  X«T 
DIMENSION  W<2) 

EQUIVALENCE(T«W(1)» 

DATA  R/777777777777400000000/ 

T«X 

N(U«AN0<W(1I,R> 

W(2}«AN0(Wf2)«R) 

QlCOHPsT 

RETURN 

END 
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36  Bits 


REAL  fUMCTION  QlREALU) 

DATA  R/77777777777700000000fl/ 
Q1REAL:AN0U«R> 

RE  TURN 
ENO 

DOUBLE  PRECISION  FUNCTION  QIOPRE(X) 
DOUBLE  PRECISION  X.T 
OXHENSION  Wt2) 

EQUIVALENCE(T,M<in 

data  R/77777777777700QQ0000a/ 

T = X 

M<nsANO(N(l),R) 

W<2)=ANO(W(2)tR) 

QlOPREs  T 
RE  TURN 
END 

complex  func  r^N  aiC0MP(xj 
complex  X,T 
DIMENSION  N(2) 

equivalence  n,Nm) 

data  R/777777777777J00000008/ 

T-X 

M(l)=ANa(W(l)«R) 

N(2) sANQ(M (2) ,R) 

QlCOMP=T 

RETURN 

END 


35  Bi ts 


real  FUNCTION  QlREALfX) 

DATA  R/77777777777b30000000B/ 

QlRE AL=ANOfX,RI 

RETURN 

ENO 

DOUBLE  PRECISION  FUNCTION  QlOPRE(X) 

DOUBLE  PRECISION  X,T 
DIMENSION  H(2) 

EQUIVALENCE(r«N(in 

data  R/777777777776000000009/ 

T=X 

W< 1) -and (Wfl ) «R) 

M(2):AN0<M(2)fRI  j 

QlOPRE=T 

RETURN 

ENO 

COMPLEX  FUNCTION  QICOMPCXI 
COMPLEX  X,T 
DIMENSION  N(2) 

EQUIVALENCE  (T  ,N(1  I ) 

DATA  R/777777777776000000000/ 

T=X 

MU)<ANQ<HU  WR) 

W(2I =ANOI NC2) «R) 

QlCOMPxT 
RE  turn 
ENO 


1 10 


b 


34  Bits 


REAL  FUNCTION  QlREAt.nO 

data  R/77777r7777F4000000008/ 

Q1REAL=AN0(X,R) 

RETURN 

ENO 

DOUBLE  PRECISION  FUNCTION  QIOPRE(K) 
DOUBLE  PRECISION  X,T 
DIMENSION  Mie> 

EQUIVALENCE  fr«N(l )) 

DATA  R/777777777774000000008/ 

T = X 

U(i):ANO(M(l)«R) 

W<2)>AND(M(3)«R) 

QlOPRE=T 

RETURN 

ENO 

COMPLEX  FUNCTION  QlCOHP(X) 
complex  X,T 
DIMENSION  Wf3> 

EQUIVALENCE  (T«NU  )) 

data  R/777777777774000000008/ 

T*X 

H<l)=ANO(M(l)«R) 

N(2)=AN0(N<2),R> 

QlCOMPsT 

RETURN 

END 


33  Bits 


REAL  FUNCTION  Q1REAL(X» 

DATA  R/777777777770000000008/ 
Q1REALsANO(X«R) 

RETURN 

ENO 

DOUBLE  PRECISION  FUNCTION  QIOPRECX) 
DOUBLE  PRECISION  X» T 
DIMENSION  W<2) 

EQUIVALENCE(T«H(in 

DATA  R777777777777000000000B/ 

r=x 

HU)=AN0(M<U  ,R) 

M(2)3AND(W(2) fR) 

010PRE=  T 
RE  TURN 
ENO 

COMPLEX  FUNCTION  QlCOMP(X) 
complex  X«T 
DIMENSION  N(2) 

equivalence (T ,m(i n 

DATA  R/ 777777777770000000008/ 

T = X 

NU)sANOCN(n  «R) 

M(2)=AND(M(2>,R) 

QICOMPsT 

RETURN 

ENO 


real  function  QIREALIX) 

DATA  R/ 777777777760000000008/ 
Q1REAlsANO(X,R) 

return 

END 

DOUBLE  PRECISION  FUNCTION  QIOPRECX) 

DOUBLE  PRECISION  X,T 

OIHENSION 

EQUIVALENCE (T,U(1 )) 

DATA  R/77777777776000Q000008/ 

T = X 

M(l)=ANO(Nm«R) 

M(2)=ANO(W(2)tR> 

Q10PR£=T 

RETURN 

END 

COHPLEX  FUNCTION  OlCONPIX) 

COMPLEX  X,T 
DIMENSION  W(2) 

EQUIVALENCE  (T,WU  )) 

DATA  R/777777777760000000009/ 

T = X 

W(U=AN0(N(U  fR> 

H(2>=ANO(W(2>«R) 

QlCOMP=T 

RETURN 

END 


31  Bits 


REAL  function  QIREAL(X) 

DATA  R/77777777774030Q000003/ 

oireal  = anocx*pi 

return 

END 

DOUBLE  PRECISION  FUNCTION  QlOPRE(X) 
DOUBLE  PRECISION  X, T 
DIMENSION  M(2> 

equivalence  I )) 

data  R/777777777740000000008/ 

T=X 

W(ll=ANO(W(n«R) 

W(2)=AND(M(2) «R) 

Q1DPR£=T 

RETURN 

END 

COMPLEX  FUNCTION  QlCOMPCXI 

complex  x*t 

DIMENSION  W<2) 

EQUlVALENCEIT«Wfl>) 

DATA  R/77777777774000000000B/ 

Ts  X 

Ha)sANO(W(l)«R) 

M(2):AN0(M<2),R) 

QlCOMPs  T 
RE  turn 
END 


1 1 ; 


30  Bits 


REAL  function  QlREAL(X) 

OATA  R/77r7777777aOOOOOOOOO0/ 
Q1REAL:AN0(X»R) 

RE  TURN 
END 

OOU0LE  PRECISION  FUNCTION  QIOPREIX) 
OOUBLt  PRECISION  X,T 
OIHENSION  M<?) 

EQUIVALENCE(T,H(1)) 

OATA  R/777777777700000000000/ 

TsX 

H ( 1) >ANO(H (1 ) tR) 

H(2)=AN0(M(2)«R) 

QIDPR£=T 
RE  TURN 
ENO 

complex  FUNCTION  QlCOMP(X) 

COMPLEX  X,T 
OIHFNSION  N(2» 

EQUIVALENCE(rtN(l M 

OATA  R/777777777700000000000/ 

TsX 

N ( 1)  :ANO  (MU)  »R) 

M(2) =AN0(W(2 ) *R) 

Q1C0MP=T 

RETURN 

ENO 


1 1 i 


subroutine  re»lck 

real 

2 

COMMON  .0(SOO»,IDTBL(B.SOO).INITIO(3t 

«L  ASTIOI  31  *ISRCH(3  1* 

RICH 

2 

• JPTR,N,M,JTrP,LST»RT,N?,  IFNCNM,  LOGIOt  NX  TIO, 

10  typ,nio»loc* 

CYSOA 

60 

2 LTTP, ITYP.ISLKOT.MOOEtlERR, IOES 

RICH 

4 

COMMON/LOGIC/L  OG.LOGST 

REAL 

4 

COMMON/REXLNO/IREAL.IRELNO.IP 

REAL 

5 

INTEGER  », DEC P T, E EE. PLUS, MINUS, OEE, EL OC 

REAL 

6 

OAT*  OECPT/IM. /.EEE/IHE/,  PLUS/IH*/,  MINUS/IH- 

/,OEE/lHO/ 

REAL 

7 

THIS  routine  checks  a character  string  to  see 

IF 

IT  CONSTITUTES 

REAL 

0 

A REAL  NUMBER 

REAL 

9 

IOES«0 

REAL 

10 

IRELNO  = 0 

real 

11 

IF  IIP  .GE.  N)  GO  TO  90 

REAL 

12 

CHECK  THAT  FIRST  CHARACTER  IS  A HECIMAL  POINT 

OR 

NUMBER 

real 

13 

tEINEKTIIP»  .EQ.  OECPTI  GO  TO  5 

REAL 

14 

IFUTYPEIIPI  .EQ.  2)  GO  TO  10 

REAL 

15 

GO  TO  90 

REAL 

16 

5 IFUPTR  .CT.  N)  GO  TO  90 

REAL 

17 

IF CITYPE IJPTR)  .NE.  2»  GO  TO  90 

REAL 

IS 

GO  TO  20 

REAL 

19 

10  IFCJPTR  .GT.  NI  GO  TO  90 

REAL 

20 

12  IFIITYPEIJPTRI  .EQ.  21  GO  TO  15 

REAL 

21 

‘ CHECK  THAT  STRING  CONTAINS  A DECIMAL  POINT 

REAL 

22 

IFIAIJPTR-1)  .NE.  OECPTI  GO  TO  90 

REAL 

23 

LOGSTsJPTr 

REAL 

24 

CALL  LOGCHK 

REAL 

25 

IFILOG  .EO.  11  GO  TO  90 

REAL 

26 

JPTR=LOGST 

REAL 

27 

GO  TO  20 

REAL 

20 

15  IFIJPTR  .GT.  NI  GO  TO  90 

REAL 

29 

GO  TO  12 

REAL 

30 

20  IREAL*1 

REAL 

31 

IFIJPTR  .GT.  NI  GO  TO  35 

REAL 

32 

22  IFflTYPEIJPTRI  .EQ.  2>  GO  TO  25 

REAL 

33 

IFUIJPTR-ll  .EO.  EEEI  GO  TO  24 

REAL 

34 

IFIAUPTR-ll  .NE.  OEEI  GO  TO  30 

REAL 

35 

lOESsl 

REAL 

36 

24  ELOC*JPTR-2 

REAL 

37 

GO  TO  40 

REAL 

30 

25  IFIJPTR  .GT.  NI  GO  TO  35 

REAL 

39 

GO  TO  22 

REAL 

40 

30  ELOC*JPTR-2 

REAL 

41 

32  IRELNO=ELOC 

REAL 

42 

NUMBER  IS  NOT  IN  “E“  uR  "0~  FORMAT*  RETURN 

REAL 

43 

return 

REAL 

44 

35  rRELNO*N 

REAL 

45 

RE  TURN 

REAL 

46 

40  IFIJPTR  .GT*  NI  GO  TO  32 

REAL 

47 

‘ NUMBER  IS  *E-  OR  -0"  FORMAT 

REAL 

40 

nkt*nekt  ijptri 

RFAL 

49 

IFINKT  .EO.  PLUS  .OR.  NtT  .EO.  MINUSI  GO  TO 

45 

REAL 

50 

IF  IITYPE 1 JPTR-ll  .NE.  21  GO  TO  32 

REAL 

51 

IFIJPTR  .CT.  NI  GO  TO  35 

REAL 

52 

GO  TO  47 

REAL 

53 

45  IFIJPTR  ,GT.  NI  GO  TO  32 

REAL 

54 

IFIITYPEIJPTRI  .NE.  21  GO  TO  32 

REAL 

55 

47  IFIITYPEIJPTRI  .EO.  21  GO  TO  50 

REAL 

56 

IRFLW0»JPTR-2 

real 

57 

Rf  TURN 

REAL 

50 

50  IFIJPTR  ,GT.  NI  GO  TO  35 

REAL 

59 

GO  TO  47 

REAL 

60 

90  !REAL«0 

REAL 

61 

RETURN 

REAL 

62 

ENO 

REAL 

63 

FORTRAN  Version 


SUBROUTINE  RECOGCFIN) 

COMMON/LVflRGS/LVFUNCtL  VVARG*LV  VAOtL  VVPOS  ,L  VVTYP,  LVVAt  , 

♦ LVHEAOtL VVNVL  tLVOEST,LVVftlS< 10  » , L VT Y PE  1 1 0) * L VS KI P 
C0MM0N/LVTABL/LVTSI7,LVHAP(  1) /LVVSFQ/LVSIZE,LVSOSP ( U 

CONHON  /HL/  HOLt ACTION, FUNCl ♦FUNC?fFUNC3  ,LEFT» RIGHT, STRINGfHAXJ 
COMMON  /need/  start, assoc, LEVEL  I stop 
COMMON  /string/  NNNC?»,STp 

COMMON/NEEOS/STJ, JSTACK,R, JAS, J, JLAST , RT  EMP , ST  AC K < 40 0 > 

INTEGER  HOL 

INTtGEP  START  , A SSOC ,ST OP , RETRN , R , S T J, S T A CK , S TR  <1  I , ACT  I ON, STP TNG, 
f RTEMP 

logical  fail, fin 

FIN=. FALSE. 

GO  TO  ?5000 
?500  1 CONTINUE 
JSTACK=0 
J=1 

R = START 

LVVPOS  = J 

LVVTYP  s 3 
LVFUNC=  string 

LVVAPG*  string 

call  LvFiNoava  a,lv?  b,lv2  c,lv?  O) 

LVl  AAO  = string 

IF  ILVVAL.NE. 'll  LVl  AAO  = LVVAL 
LVVTP  = LVVAL 
LVVAL  = -100 

IF  tlvvtr.eo. -1)  go  to  70 

STJ  = LVl  AAO 

M=-l 

LVVPOS  = 1 

LVVTYP  s 3 
LVFUNC=  HOL 

LVVARGs  STRING 

CALL  LVFIN0aV2  E,LV2  F,LV?  G ,L  V?  H) 

LVl  AAO  = string 

IF  <L VVAL.NE. -II  LVl  AAO  = LVVAL 

LVOEST=  0 

LVl  AAH  = N 

LVTYPE  <11=  I 

LVVALSdi  = LVl  AAH 

LVOFST=  0 

LVVNVL  = 1 

LVFUNC  = STRING 

IVVAPG=LVI  AAO 

CALL  LVNSRT 

if(lvval.lt.gi  call  LVEXIKLVVALI 
IF (LVVAL .LT .0  I RETURN 
ft  CONTINUE 

1?  continue 

LVl  AAD  = P 

LVVTYP  = 3 

LVVPOS  = 1 

LVINOK  = 0 

LVFUNC=  ASSOC 

LVVAPG=  LVl  AAD 

call  LVPIN0(L VINO*,LVINOX,LVINnX,LVINO*l 


PECOG  2 


RECOG  3 
PECOG  4 
RECOC  5 
PECOG  6 
PECOG  7 
RECOG  8 
PECOG  9 
PECOG  10 
PECOG  11 


PECOG  13 
PECOG  14 


PECOG  17 


PECOG  19 


J 


LVl  flfti  = LVl  AAO 

IF  ILVVAL*NE.-1)  LVl  AAI  « LVVAL 
LVVTP  s tVVAt 
LVVAl  s -100 

IF  ILVVTP.NE.-1)  GO  TO  15 

LVVTYP  s 3 
LVVPOS  = 1 
LVINOJf  s 0 

lvfunc=  stop 

LVVApG=  LVl  AAO 

CALL  LVFINO  lLVINnx,LVINOX,LVrMOX,LVrNO)f| 

LVl  AAI  = LVl  AAO 

IF  IlVVAL.NE.-1)  LVl  AAI  = LVVAL 
LVVTp  = LVVAl 
LVVAL  = -133 

IF  fLVVTP.NE.-l)  GO  TO  15 

LVVAL  = -100 

IF  (LVl  AAQ.NE.  STOP)  LVVAL  * -1 

LVVTP  = LVVAL 
LVVAL  = -100 

IF  (LVVTp.EO. - 1)  GO  TO  20 

15  JSTaC<=JSTACK*1  pECOG  21 

^■TACKI JSTACK)  =SMIFT  (R,4*5)  .OP.  SHIFTfJ.lE)  PFCOG  22 

23  CONTINUF 
LVVTYP  = 3 
LVVPOS  = 1 
LVINDX  = 0 
LVFUNCs  action 

LVVAPG=  P 

CALL  L VFr  NO  fL  VINO  Y,  LVl  NO*.  LVINOY»L  VINO  V) 

LVl  AAO  = P 

IF  (LVVAL. NE. -1)  LVl  AAO  s LVVAL 
LVVTP  = LVVAL 
LVVAL  = -100 

IF  (LVVTP.EO. - 1)  GO  TO  22 


N s LVl  AAO 


CALL  SFHANT  (N,  FA  ID 

PECOG 

24 

IF  (FAIL) 

GO  TO  99 

PECOG 

25 

GO  TO  29 

PECOG 

26 

22  CONTINUE 

LVVTYP  s 

3 

LVVPOS  = 

1 

LVINOY  s 

0 

lvfunc= 

STJ 

LVVAPGs 

P 

CALL  LVFIN0(LV1N0X.LVIN0X,LVIN0Y,LVIN0Y) 

LVl  AAO  = P 

IF  UVVAL.NE.-1)  LVl  AAO  = LVVAL 
LVVTP  = LVVAl 
LVVAL  = -100 

IF  (LVVTP.EO. -1)  GO  TO  99 

P = LVl  AAO 

J*J»1  PECOG  28 

IF(J  .GT,  MAXJ)  MAXJ=J  PECOG  29 

T1  CONTINUE 

LVVPOS  = J 

LVVTYP  r 3 


I Ih  i 

i 

I 

J 


LVruNCs  string 

IVVARG=  string 

CALL  LVFIN0CLV2  I*LV?  J.LV?  »C*LV?  U 

LVl  AAO  3 string 

IF  fLVVAL,N€.-ll  LVt  AAO  « LVVAL 
STJ  * LVl  AAO 

LWTR  » LVVAL 
LVVAL  3 -100 

IF  (LVVTR.NC.  -1»  go  to  6 

AO  STjs-l 

LVVTVP  * 3 
LVVPOS  = 1 
LVINOX  « 0 
LVFUNC3  ACTION 

LVVARG*  R 

CALL  LVFTNOIL VINOX,L VINOX,LVINOX,LVINOX| 

LVl  AAO  3 R 

IF  (LVVAL.NE. -II  LVl  AAO  « LVVAL 
LWTR  = LVVAL 
LVVAL  = -100 

IF  CLVVTR.EO. -II  GO  TO  42 

N s L VI  AAO 

CALL  SFHANT(N,FAIL) 

IFCFAILI  GO  TO  99 
42  CALL  SST0P<FAIL) 

IFfFAU»  GO  TO  99 
JSTACKsJSTAC^^l 

STACKIJSTACKI*SMIFTIR,45I  .OR,  SHtFTlJ.151 

LVVTVP  = 3 

LVVPOS  « 1 

LVINOX  s 0 

LVFUNC*  ACTION 

LVVARG3  p 

CALL  LVFINOfLVINOX,LVINOX,LVINnx,LVINOXI 
LVl  AAO  s R 

IF  (LVVAL.NE.-l)  LVl  AAO  « LVVAL 
LWTR  s LVVAL 
LVVAL  * -100 

IF  CLVVTR.EO. -II  GO  TO  44 

N 3 LVl  AAO 
CALL  SeMANTfN.FAILI 
IF  If AILI  GO  T 0 99 
44  call  SLFVELCFAIL) 

IFCFAIL)  RETJPN 
GO  TO  40 
99  CONTINUE 

CALL  RfCOVIRETRNI 
IF  CRETPN  .LT.  01  GO  TO  70 
LVVAL  3 -100 

IF  I RETRN.NE.  ASSOCI  LVVAL  * -1 

LWTR  = LVVAL 
LVVAL  * -100 

IF  ILVVTR.NE.-ll  GO  TO  30 

IF  CRETRN  .EQ.  01  GO  TO  10 
CALL  SLCVELIFAILI 
IFIFAILI  CO  TO  65 
GO  TO  30 

65  IFfJSTACK  .LE.  II  GO  TO  70 
JSTACK*JSTACK-1 
GO  TO  99 
70  FIN3,TPUE. 

RETURN 

return 

25000  CONTINUE 


LV? 

A3LV2 

fl»LV2 

C-IV2 

0*0 

LV2 

E3LV2 

F*LV2 

G*LV? 

H«0 

LV2 

I»LV2 

J*LV2 

KaLVZ 

L-O 

GO  TO 

25001 

ENO 


RECOG  31 


RECOG  33 
RECOG  34 
RECOG  35 
RECOG  36 
RECOG  37 
RECOG  38 


RECOG  40 
RECOG  41 
RECOG  42 
RECOG  43 
RECOG  44 
RECOG  45 
RECOG  46 
RECOG  47 


RECOG  49 
RECOG  50 
RECOG  51 
RECOG  52 
RECOG  53 
RECOG  54 
RECOG  55 
RECOG  56 
RECOG  57 
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$ 

subroutine  recocifini 

RfCOG 

2 

COHHON  /Ml/  HOIi*CTION,FUNC1.FUNCE.FUNC3 .left, RIGHT, STRING, N*XJ 

RrCOG 

3 

COMMON  /NEED/  START, *SSOC, LEVEL, STOP 

fttCOG 

4 

COMMON  /STRING/  NNN(2I,STR 

RfCOG 

5 

COMMON/NEEOS/STJ,  JSTACtt.R,  J4S,  J,  JLAST.RT EMP.ST  ACKC%at> 

RfCOG 

6 

INTEGER  HOl 

RfCOG 

7 

INTEGER  START  , ASSOC,STOP.RETRN,R,STJ,STACit.STR  11  > , ACT  I ON,  STR  ING, 

RfCOG 

8 

S RTEHP 

RfCOG 

9 

LOGICAL  FAIL.FIN 

RfCOG 

18 

FIN=. FALSE. 

RfCOG 

It 

G 

EXECUTE 

RfCOG 

12 

JSTACX=0 

RfCOG 

13 

J*  1 

RfCOG 

14 

G 

START  'R 

RfCOG 

19 

G 

STRING*STRING. J/70  *STJ 

RfCOG 

16 

M=-l 

RfCOG 

17 

G 

STRINGAHOL.l  string  ••M*' 

RfCOG 

IS 

6 

continue 

RfCOG 

19 

G 

10 

R(*ASS0C//15,  ♦STOP//1S,  = STOP/70) 

RfCOG 

28 

15 

JSTACK= JSTACRFl 

RfCOG 

21 

STACK! JSTACKt •SHIFT«R,45»  .OR.  SHIFT!J,15» 

RfCOG 

22 

G 

30 

RfACTION/22  'N 

RfCOG 

23 

CALL  SEMANTIN.FAILt 

RfCOG 

24 

IFIFAIU  GO  TO  99 

RfCOG 

29 

GO  To  25 

RfCOG 

26 

G 

32 

RASTj/99  *R 

RfCOG 

27 

35 

JsJ»l 

RfCOG 

28 

IF(J  .GT.  MAXJI  MAXJiJ 

RfCOG 

29 

G 

30 

STRING FSTRINC. J 'STJ//6 

RfCOG 

38 

40 

STJ«-1 

RfCOG 

31 

G 

RFACTION/42  *N 

RfCOG 

32 

call  semantin.faili 

RfCOG 

33 

IFIFAIL)  GO  TO  99 

RfCOG 

34 

43 

CALL  SSTOP!FAIL» 

RfCOG 

39 

IFIFAIU  GO  TO  99 

RfCOG 

36 

JSTACK«JSTACK»l 

RfCOG 

37 

STACKIJSTACKI  *SHIFT(R,4S)  .OR.  SHIFXU.ISI 

RfCOG 

38 

G 

RFACTION/44  'N 

RfCOG 

39 

call  SEMANT(n,FAIL> 

RfCOG 

48 

IFIFAIU  GO  TO  99 

RfCOG 

41 

44 

CALL  SLEVELIFAILI 

RfCOG 

42 

IFIFAILI  RETURN 

RfCOG 

43 

GO  TO  40 

RfCOG 

44 

99 

CONTINUE 

RfCOG 

49 

CALL  RECOVIRETRNI 

RfCOG 

46 

IFIRETRN  .LT.  01  GO  TO  TO 

RfCOG 

47 

G 

RETRN«ASSOC//30 

RfCOG 

48 

IFIRETRN  .EQ.  01  GO  TO  10 

RfCOG 

49 

CALL  SLEVELIFAILI 

RfCOG 

98 

IFIFAILI  GO  TO  65 

RfCOG 

91 

GO  TO  30 

RfCOG 

92 

65 

IFIJSTACK  .LE.  11  GO  TO  TO 

RfCOG 

93 

JSTACK»JSTACif-l 

RfCOG 

94 

GO  TO  99 

RfCOG 

95 

70 

FIN«,TROE. 

RfCOG 

96 

RETURN 

RfCOG 

57 

G 

complete 

RfCOG 

98 

1 IH 

J 
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subroutine  RECOV(RETRN) 

COMHON/LVARGS/LVFUNC.L  VVARG*LV  VAO.LVVPOS  •LVVTYP,  LVVU* 

♦ LVHEAOaVVNVL»LVOEST,LVVALSl  10  » ♦ L VT  YPE  Cl  0)  tL  VSKIP 
COHMON/LVTABL/tVTSIZ.LVHAPC  II /L  WSEQ /L  VS  17  E*  L VSOSP  ( II 

common  /need/  START*ASSOCf LEVEL$ST0P 

COHHON/NEEOS/STJ, JSTACK,R« JAS«  Jt JLAST.RTEMP*  ST ackc^ooi 
common  /string/  NNNI7I»STR 

COMMON  /ML/  H0L*ACTI0N,FUNC1*PUNC7iFuNC3*LEFT, RIGHT, string 
INTEGER  START, ASSOC, STOP,STACK, ST R (II , ST  J, R, ST RI NG ,RET RN, TEMP 
S , RIGHT, HOL,aiTGET,BITPUT 
GO  TO  25000 
25001  CONTINUE 

10  R=PITGETISTACK(JSTACKI ,15,151 

JAS=BITGET (STACK CJSTACKl , 30,151 ♦! 

LVVPOS  » JAS 

LVVTYP  s 3 
LVFUNC»  ASSOC 


LVVAPG= 

call  LVFIN0(LV2 

R 

A,l 

L V2 

e,LV2 

LVl  AAO  = 

IF  CLVVAL,NE,-1I 

LVl 

P 

AAO  > 

LVVAL 

TEMP  s LVl 
LVVTR  s LVVAL 
LVVAL  = -100 
IF  (LVVTR, NE. -11 

GO 

AAO 

TO 

30 

15  CONTINUE 

LVl  AAO  = 

LVVAL  = -100 
IF  (LVl  . AAO.NE 

R 

STOP) 

LVVAL  = -1 

LVVTR  = LVVAL 
LVVAL  = -100 
IF  (LVVTR, NE,-1I 

GO 

TO 

40 

LVVTYP  s 3 
LVVPOS  = 1 
LVINO)(  = 0 
LVFUNC=  STOP 

LVVARG:  LVl  AAO 

CALL  LVFINO (L V INOX ,L V INO X , LV INHX , L VINOXI 

LVl  AAH  * L VI 

IF  (LVVAL. NE. -11 

LVl 

AAO 

AAH  : 

LVVAL 

LVVTR  = LVVAL 
LVVAL  = -100 
IF  (LVVTR. EO. -11 

GO 

TO 

16 

LVVAL  = -100 
IF  (LVl  AAH.NE 

STOP) 

LVVAL  * -1 

LVVTR  = LVVAL 
LVVAL  s -100 
IF  (LVVTR, NE. -11 

GO 

TO 

40 

P * LVl  AAh 


J=eiTGETC$TACK (JSTACKI  ,45,15) 

JSTACK=JSTACK-1 
RETPN=C 
PE  TURN 

16  JSTACK=JSTAC<- 1 

IF ( JSTACK  .LF . 01  GO  TO  20 

IF  CBITGET  (STACK  (JSTACK)  ,45,151  ,LT,  Jl  CALL  SE  MA  NT  (0  ,F  A U I 
J=RITGrT(STACK< JSTACKI ,45, 15) 


RECOV  2 


RFCOV  3 
PECOV  4 
PECOV  5 
RECOV  6 
PECOV  7 
PECOV  6 


RECOV  10 
RECOV  11 


PECOV  14 
PECOV  15 
PECOV  16 
RECOV  17 
PECOV  18 
PECOV  19 
PECOV  20 
PECOV  21 


{ 


GO  ro  10 

2<i  RETRNs-1 
RETURN 

40  continue 

J= BI T GET f STACK ( JS T ACK) ,45 , 15 > 

ISTCK»BITGET(STACKUSTACK I ,60,151 
IFIISTCK  .GT.  0 .AND,  ISTCK  .lT.  7777701  60  TO  16 
RETRN*ST0P 
RETURN 
TO  continue 

R = TEMP 

IFfJSTACK  ,E0.  n GO  TO  35 

IFCR  .NE,  0ITGETCSTACKUSTACK*  ,15,1511  GOTO  35 
NTEMP=flITGET<STACK(  JSTACK-U  ,15,151 
JMARK= JSTACK 

31  STACKC JMARK)=STACK(JMARK>  .OR.  777770 
JMARK= JMARK-1 

ISTCK* PI TGET<  STACK (JMARK I ,15,15> 

TFIR  .FO.  ISTCK  .ANO.  81  TGET  I S TACK  UMARK  I , 60  , 1 5>  .EO.  7777701 
$ GO  TO  15 

IFIR  .EQ.  ISTCK  .AND.  JMARK  .NE.  0»  GO  TO  31 
IFIP  .NE.  NT^MP  .OR.  JAS  . NE . B ITGE  T < S TA  CK  ( JST  ACK«  1)  , 30 , 15 1 
S .OR.  BITGET!STACK<JSTACK-1) ,60 ,151  .NE.  777770)  GO  TO  35 
GO  TO  15 
35  CONTINUE 

IFIBITCFT|STAC<IJSTACK),45,15)  .LT.  J)  CALL  SE  MANT  CO  ,F  A IL ) 
STACKC JSTACK) sSTACKCJSTACKI  .AND.  777770000077777777778 
STACK! JSTACK)  » BI T PUT C STACK C JST ACK) , J AS , 3 0) 

J=«I TGET (STACK! JSTACK)  ,45,15) 

IF (BIT  GET (STACK! JSTACK) ,60,15)  .NE.  77  7770) 

S STACKCJSTACKI  sSTACKCJSTACKI  .ANO.  777 77 7777 77 7777 00 00 08 
RETRNsASSOC 
RETURN 
RETURN 

75000  CONTINUE 

LV?  A=LV2  B*LV?  C*LV2  0*C 

GO  TO  75001 

END 


PECOV 

77 

RECOV 

73 

RECOV 

74 

RECOV 

75 

PECOV 

76 

RECOV 

77 

RECOV 

28 

RECOV 

79 

PECOV 

30 

RECOV 

37 

PECOV 

33 

PECOV 

34 

RECOV 

35 

PECOV 

36 

RECOV 

37 

PECOV 

38 

RECOV 

39 

RECOV 

40 

RECOV 

41 

RECOV 

47 

RECOV 

43 

RECOV 

44 

RECOV 

45 

PfCOV 

46 

RECOV 

47 

PFCOV 

48 

RECOV 

49 

RECOV 

50 

RECOV 

51 

PfCOV 

57 

PECOV 

53 
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SUBROUTINC  R£COV(RETR«l 

RECOV 

3 

COHHOM  /NEED/  ST»RT,»SSOC, LEVEL. STOP 

RfCOV 

3 

COBHON/NEEOS/STJ,  JSTICK.R.JRS,  J.JLlST.RT  CMP.  STACK  (liO  II 

RECOV 

4 

COMMON  /STRING/  NNNIEI.STR 

RECOV 

5 

COMMON  /ML/  HOL. ACTION, FUNC1.EUNC2.FUNC3. LEFT, right, STRING 

RECOV 

6 

INTEGER  START,  ASSOC, STOP.STACK.STR (11 , ST J, R, ST RI NG.RETRN, TEMP 

RECOV 

7 

t .RIGHT, MOL, BITGET.BITPUT 

RECOV 

6 

EKECOTE 

RECOV 

9 

10 

R^BITGET (STACK (JSTACKI ,1S,1SI 

RECCV 

10 

JAS«SITGET (STACK (JSTACKI , 30, ISI »t 

RECOV 

11 

R*ASSOC.JAS  'TEMP//30 

RECOV 

17 

IS 

R(«STOP//(,0,*STOP/16»STOP//(,0  *RI 

RECOV 

13 

J*BIT6£T(STACK(JSTACKI  ,<,5,151 

REC  CV 

14 

JSTACK*JSTACK-1 

RECOV 

15 

RETRN>0 

RECOV 

16 

RETURN 

RECOV 

17 

16 

JSTACK*JSTACK-1 

RECOV 

IS 

IF(J5TACK  ,LE.  0 1 go  to  ?0 

RECOV 

19 

IF(BITGET(STACK(JSTACKI,<,5,15I  ,lt.  ji  call  SEMANT  (O.FAILI 

RECOV 

70 

J>BITGET  (STACK  (JSTACKI  ,1,5,151 

RECOV 

71 

GO  TO  10 

RECOV 

77 

?0 

RETRN»-1 

RECOV 

73 

RETURN 

RECOV 

74 

40 

CONTINUE 

RECOV 

75 

J<BITGET(STACK(JSTACKI  ,(,5,151 

RECOV 

76 

ISTCK. BIT  GET (STACK (JSTACKI ,60,151 

RECOV 

77 

IFdSTCK  ,GT.  0 ,ANO,  ISTCK  ,LT.  TT777BI  GO  TO  16 

RECOV 

76 

RETRN«STOP 

RECOV 

79 

RETURN 

RECOV 

30 

30 

TEMP  'R 

RECOV 

31 

IF(JSTACK  .EO.  11  GO  TO  35 

RECOV 

37 

IF(R  ,NE.  BITGET  (STACK  (JSTACKI  ,15,151  I GO  TO  35 

RECOV 

33 

NTEMP«  BITGET(STACK(JSTACK- 11 , 15,151 

RECOV 

34 

JMARK> JSTACK 

RECOV 

35 

31 

STACK! JMARKI*STACK(JMARKI  .OR.  77777B 

RECOV 

36 

JHARKsJMARK-1 

RECOV 

37 

ISTCK<6I TOE T( STACK! JMARKI ,15,151 

RECOV 

36 

IF(R  ,EQ.  ISTCK  .AND.  BIT  GET  (ST  ACK  ( JMA  RK  1 , 60  ,1  51  ,EO.  77777BI 

RECCV 

39 

t GO  TO  15 

RECOV 

40 

IF(R  .EO,  ISTCK  ,ANO.  JNARK  .NE,  01  GO  TO  31 

RECOV 

41 

IF(R  ,NE.  NTENP  .OR,  JAS  . NE . BI TGE  T ( S TA  CK  ( JST  ACK-1 1 , 30 , 15 1 

RECOV 

47 

t .OR.  BITGCT(STACK(JSTACK-1I  ,60, 151  ,NE,  77777BI  GO  TO  35 

RECOV 

43 

GO  TO  15 

RECOV 

44 

35 

CONTINUE 

RECOV 

45 

IF(BITGET(STACK(  JSTACKI, 1.5. 151  ,LT.  JI  CALL  SE  MANT  (0  ,F  AIL  1 

RECOV 

46 

STACKIJSTACKI  >STACK(JSTACKI  .ANO,  777 770 0000  77 77 7 77777 B 

RECOV 

47 

ST  ACK  (JSTACKI  • BIT  PUT  (STACK  (JSTACKI.  JAS,  3 01 

RECOV 

46 

J<BITGET(STACKIJSTACKI  ,65,151 

RECOV 

49 

IF(BITGET(STACK(JSTACKI,6B,15I  ,NE.  77777BI 

RECOV 

50 

S STACKIJSTACKI >STACK(JSTACKI  ,ANO.  777777777777777000008 

RECOV 

51 

RE  TRN«  ASSOC 

RECOV 

5? 

RETURN 

RECOV 

53 

complete 

RECOV 

54 

SURPGUt I Nf  POLCHK (II • 

DIMENSION  IA=»G(61 

DATA  hAS</7700  000  00000  00  0 00033*^/ 

IAPGI1)=I1  .and.  mask 

IAPG(2>=I3  .and.  mask 

IAPG(3)=I3  .AND.  MASK 

IAPG(4)=IU  .and.  mask 

IAPG(5)=I5  .and.  mask 

IAPG(6)=I6  .and.  mask 

ISUBNM=S5555S55B 

NSHIFT=66 

DO  i;  I=l,6 

NSHIFT=nSHIFT-6 

I : ISUBNMsOP ( ISU0NM, SHIFT (IAPG( I ) . NSMIFT)  > 

MPIT: I 3J  ISU^NM 
PETUPN 
END 


SUBROUTINE  SEARCH 

SEARCH 

2 

COMMON  A I13E6)  ,0  ISOOl  t IOTBL(8,S00).INITI  0(3>  .L  ASTIOdI  . ISRCHC3  1, 

RICH 

2 

• JPTR.N.N,  JTTP.LSTART.N?,  IFNCNH.LOGID.NXTID,  10  TTP.NIO.LOC. 

CTSBA 

00 

2 LTTP.ITTP.IBLROT.HOOE.IERR.  IDES 

RICH 

% 

c*>  THIS  routine  se.rches  The  sthbol  table  for  a nahe  and  returns 

SEARCH 

k 

tSRCH(ll«l  - NAMe  FOUND  IN  VARIABLE  LIST  «0  - NOT  FOUND 

SEARCH 

s 

ISRCH(2)«1  - NAME  FOUND  IN  FUNCTION  LIST  *0  - NOT  FOUND 

SEARCH 

6 

C** 

LOG  ' STHBOL  TABLE  LOCATION  WHERE  NAME  MAS  FOUND 

SEARCH 

7 

DO  20  K«l«2 

SEARCH 

8 

INITIO (K) 

SEARCH 

S 

IFIJ  .EQ.  0)  GO  TO  IS 

SEARCH 

10 

DO  10  I«l«NIO 

SEARCH 

11 

IF  (lOTBL  <ltJ>  *NE.  NXTIO)  GO  TO  5 

SEARCH 

12 

ISRCH(KI«1 

SEARCH 

13 

IOES*LOC 

SEARCH 

14 

LOC«J 

SEARCH 

15 

GO  TO  20 

SEARCH 

16 

5 

J«IOTBL(2«JI 

SEARCH 

17 

IFCJ  .EO«  0)  GO  TO  IS 

SEARCH 

10 

10 

CONTINUE 

SEARCH 

19 

15 

ISRCHIKI  *0 

search 

20 

20 

CONTINUE 

SEARCH 

21 

RETURN 

SEARCH 

22 

END 

SEARCH 

23 

i 
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LVVAL • 


SUPROUTINE  SrHANT  IN.FAILI 

COHHON/LVARGS/LVFUNC,LVVARGtLVVAO*LVVPOS iLVVTV P# 

♦ LVHf  aO,L  VVNVL  I LVnEST,LVVALS<  10  » ,L  VTYPE  UOI  ,L  VSKIP 
COMMON/tVT  60L/LVTSIZfLVHAPl  il /L VVSEO /tVS  IZEtL VSQSP  I 
COHHON/FUNC/  NARY<5,1?»  , M ARCS  • MRGS  < 5 0 > *FNCLO  C<  5 » , NFU  NC 
COMHON/ML/HOL. AC T I ON, FUNC 1 .FUNC? , FUNC 3 * L EFT , PI GHT,STRI ►G,MAX J 
COHMON  /TYP/  NARRAY,TYPE1,TYPE2,ERRFLG 

COMMON  /string/  NTYPE,NSTR,STR 
COMMON  /JL/  JSTOP 

COMMON  /GIRL/NTERHS,PtUS,MlNUS,SLASM,LPAR,  PPAR,C0MMA,STAR,EXP,LT, 

♦le,gt,ge,eq,ne ,or,and, not,eouals,oprano 

COMMON/NFEOS/STJ,JSTACK,R,  JAS,  J,  JIAST,RTEMP,ST  ACXUOOl 

common  /need/  start, assoc, level , stop 

C0MM0N/N0PAR/N0PAR,N0EP, NOEPTH, NFLAG 

INTEGER  h0L.ACTI0N,FUNC, LF FT , R TGM T, STR ING, RP AR ,S T J ,R ,S  TACK 

♦ ,F  XP,FUNC1 ,FUNC2,FUNC3 ,TYPEl ,TYPE?,TYPF(5» ,STR  » ,STOP 
$ , ALPHA, ret  A, GAMMA, OPR AND, EQUALS, AND, OR,  COMMA 

logical  skip,flag,errflg,fail, notflg 
integer  FUNCRF ,?ER0, BITPUT,PLUS,FL(3),8I tget 
INTEGER  GETTYP ,GE TOIM 

DATA  FLAG/.FALSE. /,FUNCRF/^6/, 7ERO/0/ 

DATA  C type  (1)  , I«1 ,5I/<*HRFAL,6HC0MPLX,6H0  0UBLE,6HINTEGR,6HL0GICL/ 
GE  TTYP (III =MOO (II , 100000  I/IOOOO 
GETOIM  (in  «MOO(  II  ,100000  01  /lOOOOO 
CO  TO  ?5000 
?5001  CONTINUE 

FA  IL  = . false. 

IF  (N  .FQ.  01  GO  TO  99R 

GO  TOdO,  ?0, 30, (*0,50, 60,70, 60, 90, 1000, 11  00,1 30  0,  1 300, lAQO, 1500, 

S 16CC I ,N 


10  CONTINUE 
LVVTYP  = 
LVWPOS  s 
LVINDX  s 
LVFUNC= 

lvvapg= 


ST  J 
R 

CALL  LVFINO (LVINOX,LVINnX,LVINnX,LVINOX) 
LVl  AAO  = R 


IF 

(L 

VVA 

L.NE. 

-1) 

LVl 

AAD  ' 

' LVVAL 

LVVTP 

= 

lvval 

lvval 

= 

-100 

IF 

(1 

VVT 

R.EO. 

-11 

GO 

TO 

11 

P * 

LVl 

AAO 

LV 

VTF 

= 

LVVAL 

LV 

val 

s 

-100 

IF 

u 

VVT 

R.NE. 

-1) 

GO 

TO 

1? 

SE 

MA 

NT 

? 

CY60 

R 

3 

SE 

MA 

nt 

4 

SF 

MA 

NT 

5 

SE 

MA 

NT 

6 

SE 

MA 

NT 

7 

SE 

MA 

NT 

a 

SF 

MA 

NT 

9 

SE 

MA 

NT 

10 

SF 

MA 

NT 

11 

SE 

MA 

NT 

1? 

SF 

MA 

NT 

IS 

SF 

MA 

NT 

14 

SE 

HA 

NT 

15 

SE 

MA 

NT 

16 

SE 

MA 

NT 

17 

SE 

HA 

NT 

16 

SE 

MA 

NT 

19 

SF 

MA 

NT 

30 

SE 

MA 

NT 

31 

SE 

MA 

NT 

33 

SE 

MA 

NT 

34 

SE 

MA 

NT35 

SE 

HA 

NT26 

SE 

MA 

NT 

37 

1 1 

FA IL=. true. 

SEMANT39 

Rf  TURN 

SFMANT30 

PR  I 

MARY  recognized 

SEMANT31 

1 3 

IF(STJ  .EO.  PLUS  .OR.  STJ  .EO.  MINUSI  GO  TO  136 

SFmANT.13 

IF(STJ  .NE.  RPAR)  GO  TO  131 

SEMANT33 

jstack=jstac<  ♦ 1 

Sf  manT  34 

'^TACKIJSTACKI  xSHiFT  (STOP, 451  .OP.  SHIFT(J,15I 

SFMANT35 

NTMprR 

SFMANT  36 

CALL  SlEVEL(SKIP> 

SFMANT  T7 

jSTACK=jSTACK-t 

^‘FMANTTa 

Pa  NT  MP 

SF  mANT  39 

SEHANT40 

SEMANT41 


JLflST«l 

TFUSTOP  .GT.  01  JL  AST  I TG£  T ( ACK<  JSTO  PI  . IS ) 

LVVPOS  = JIAST 

LVVTYP  s 3 
LVFUNC*  HOL 

LVVARG=  string 

CALL  LVFINO<LV2  A*^V3  8,LV?  CtLV?  0) 

LVl  AAO  s STRING 

IF  (LVVAL.NE.-1I  LVl  AAO  = LVVAL 

LVl  AAI  * LVl  AAO 

LVVAO*-l 

lvvtyp=-i 

LVVPOS*! 

LVFUNC*  STRING 
LVVARG*LV1  AAI 

call  lvolet 

LVl  AAI  * LVl  AAH 

lvoest*  Q 

LVl  AAJ  s TYPFl 
LVTYPE(l)  = 1 

LVVALS  (II  * LVl  AAJ 
LVOEST*  C 
LVVNVL  = 1 

LVFUNC  = string 

LVVARGsLVl  AAI 

CALL  LVNSRT 

IF  (LVVAL. LT.O)  call  L VFY I T (L VV AL I 
iFftVVAL  .LT.CI  RETORN 
RE  Turn. 
l?l  CONTINUE 
C GET  TYPE 

flETA*GfTOIM(STR( Jl I 
IF  (BETA  .NE.  51  GO  TO  125 
C OPERAND  IS  A FUNCTION  REFERENCE 
IF  (NOEP  .EQ.  Cl  GO  TO  18 
LVVPOS*-LVVPOS 
LVVTYP*  3 
LVVPOS*  1 

LVOEST*  2 
LVl  AAO  = 1 
LVTYPEdI  * I 
LVVALSdl  * LVl  AAO 
IVOESTs  2 
LVVNVL  * I 
LVFUNC  * FUNCI 

LVVARG*  OPRANO 
call  LVNSPT 

IFILVVAL.LT.OI  call  LVFYirrLVVAtl 
IF  (LVVAL. LT. 01  RETURN 
11  P=FUNCPF 

JSTACK* JSTAC<»1 

STACKIjSTACVIsSHIFTfRtRSI  .OR.  SMIFTrj*! ,15) 

125  ALPHA*GETTVP(STR(J)» 

IFfTYPEl  .GE.  01  GO  TO  1 3 
C SET  TYPE  OF  STATEMENT 
type i*AL PhA 

IF(NTYPF  .EO.  31  TYPE1*-1 


SEMANT43 
SEMANT4I. 
SEmanTI.5 
Sr MANT46 
SEHANTS7 
Sf MANT48 
SEMANTLB 


SEMANT51 

SEMANTS2 

SEMANTS3 

SEMANTS4 

SEHANT55 

SEMANT56 

tenants? 

SEHANTS8 


1?6  CONTINUe 
LVVPOS  = 
LVVTYP  s 3 
LVPUNC= 
LVVARG=  3 
TALL  LVFtNOa 
LVl  AAI  a 
IF  (LVVAL.NC, 
LVl  AAK  a 
LVVAOs-1 

LVVTtPx-l 

LVVPOSal 
LVFUNCa  ST 

LVVAPG=L VI 
CALL  LVOLfT 
LVl  AflK  = 
LVOFSTa  0 
LVl  AftL  * 
LVTYPem  = 
LVVALS  <1)  a L 

LVOCSTa  0 

LVVNVL  = 1 

LVFUNC  s 
LVVAPGaLVl 
CALL  LVNSRT 
IF  aVVAL.LT^Q 
IF  (LVVAL  .LT.O 
P£TUPN 

1 3 IF  CFLAG»  go  T 
CHECK  FOR  HIKED 

iFdVPEi  .eo. 

NlaTYPFl^l 
N?aALPHAfl 
FRPFLGa, TRUE. 
CALL  EPR0P(77 
LVVPOS  a 
LVVTYP  a 3 
LVFUNCa 
LVVARGa  S 

CALL  LVFINOa 
LVl  AAI  a 
IF  UVVAL.NE. 
LVl  AAK 
LVVAO=-l 
LVVTYPa-1 
L VVPOSal 
LVFUNC*  ST 

LVVAP&aLVl 
CALL  LVOLET 
LVl  AAK  a 

LVOFSTa  0 
LVl  AAM  a 
LVTYPEUI  a 
LVVALS  m a I 
LVOEST*  0 
LVVNVL  a 1 
LVFUNC  a 


F,VV7 


MOL 
TRING 

V3  F*LV? 

string 

-II  LVl  AAI  a LVVAL 
LVl  AAI 


P ING 
AAK 


G,L  V? 


LVl 


AAI 


TYPEl 

1 

VI  AAL 


STRING 

AAK 

I CALL  LVEKIT (LVVALI 
) RETURN 

0 15 

HOOE  EXPRESSION 

ALPHA  .OP.  ALPHA  .EO.  51  GO  TO  16 


, TYPETNI) .TYPFIN2I I 
J 

HOL 

TRING 

V2  I.LV2  J.LV2  K.LV? 

string 

-1)  LVl  AAI  a LVVAL 
LVl  AAI 


9 ING 
AAK 


SEHANT60 
SEHANT61 
FEHANTe? 
CYFO  I 
SEHANT64 
SFMANT65 
SEMANT66 
SFHANT67 


LI 


LVl 


AAI 


TYPEl 

1 

VI  AAH 


string 


IVVA»G*LV1  AAK 
CALL  LVNSPT 

IF  aVVAL  .LT.O)  CALL  L VEX  I T <L  V V AL  > 

IFiCVVAL  .LT.OI  RfTUPN 

PFTUPN  SEMANT69 

C OAPSING  AN  EXPONENT  SEHANT70 

15  IFULPHA  *EQ.  3 .ANO.  TYPEl  .EO.  3»  GO  TO  16  SEMAHT71 

IFMTYPEl  .EQ.  0 .OP.  TYPEl  .EO.  2t  .ANO.  (ALPHA  .EO.  0 .OR.  SEHANT72 

$ ALPHA  .EQ.  2))  GO  TO  16  SEHANT73 

CALL  EPP0P(78,J)  SCHANT7A 

FPPFLGs. true.  SEMANT75 


LVVPOS  s J 

LVVTYP  = 3 

LVFUNC=  HOL 

LVVACG=  STRING 

call  LVFiNOaV?  H.LV2  N,LV2  0.LV2  PI 

LVl  AAI  = STRING 

IF  (LVVAL.NE.-l)  LVl  AAI  » LVVAL 

LVl  AAK  = LVl  AAI 

L VVAO*-l 

lvvtvp=-i 

LVVPOS=l 

LVFUNC=  STRING 
LVVARGsLVl  AAK 

call  lvolet 

LVl  AAK  = LVl  AAI 

LVDESTs  0 

LVl  AAN  * TYPEl 

LVTyPEfi)  s 1 

LVVALS(l)  * LVl  AAN 

LVOESTs  0 

LVVNVL  = 1 

LVFUNC  = STRING 

LVVAPG=LV1  AAK 

CALL  LVNSRT 

IFfLVVAL. LT.OI  C A LL  L VEX  I T (L  V V AL  I 
IF(LVVAL.LT.CI  RETURN 

PETUPN  SCHANT77 

16  TF((,N0T.  flag  .ANO.  TYPEl  .LT,  ALPHA  I , 0 R.  (F L A G .ANO.  ALPHA  .NE.  3SEMANT78 
♦ .ANO.  TYPEl  .LT.  ALPHAH  TYPE1*ALPHA  SEMANT79 

LVVPOS  = J 

LVVTYP  = 3 

LVFUNC=  HOL 

LVVAPG*  STRING 

CALL  LVFINDCLV?  O.LV2  R.LV2  S.LV?  T» 

LVl  AAI  » STPING 

IF  (LVVAL. NE. -II  LVl  AAI  s LVVAL 

LVl  AAK  » LVl  AAI 

L VVAO=-l 

LVVTYPs-1 

LVVPOSsl 

LVFUNC*  STRING 
LVVARG=LV1  AAK 
CALL  LVDLFT 

LVl  AAK  s LVl  AAI 

LVPfST*  0 

LVl  AAO  = T YPE  I 


\2h 


LVINOK  * 

LVFUNC= 

LVV4PG* 


LVTYPEUI  * 1 

LVVALS  a>  * LVl  A40 

LVOEST=  0 

tVVNVL  ' 1 

LVFUNC  = STRING 

LVVAPG^tVl  AAK 

CALL  LVNSRT 

IMLVVAL*LT.0  I CALL  L VEX  I T CL  VV  AL I 

IF CLVVAL.LT.OI  RETURN 

RETURN 

HILL  scan  an  exponent 
30  IFCSTJ  .LT,  0)  return 
LVVTYP  « 3 
LVVPOS  s 1 
LVINOX  * 0 
LVFUNC=  STJ 

LVV4RG*  R 

call  LVFINO  Cl  vino  X,  LVINOX,  LVINOX,  LV  I NOXI 
LVl  AAl  « P 

IF  CLVVAL.NE.-ll  LVl  AAl  = LVVAL 
LVVTR  » LVVAl 
LVVAL  = -100 

IF  CLVVTR.EQ.-l)  GO  TO  11 

R » LVl  AAl 
FLAG*. TRUE. 

RETURN 

RECOGNIZED  A TERN, PRODUCT  OR  PRIMARY  PERHAPS  NEEOING  P A RE  NT  ME  S I ? AT 
30  CONTINUE 
kThPsR 

IF  CNDEP  ,EQ,  0 > GO  TO  34 

LVVPOS*-LVVPOS 

LVVTYP*  3 

LVVPOS*  1 

LVOESr*  Z 

LVl  AAl  * 1 

LVTYPECn  = 1 

LVVALS (1)  * LVl  AAl 

LVOEST*  Z 

LVVNVL  s I 

LVFUNC  * FUNCl 

LVVARG*  ORRANO 

CALL  LVNSPT 

IF(LVVAL.LT.O)  CALL  L VE X I T CL VV AL ) 

IF CLVVAL .LT,: ) RETURN 
34  continue 
ITESTsO 

IFCSTJ  .LT.  01  GO  TO  31 

LVVTYP  * 3 

LVVPOS  = I 

LVINOX  * 0 

LVFUNC*  STJ 

LVVARG*  R 

CALL  LVFINO  CL  VINO X,L VI NOX, LVINOX, LVINOX) 

LVl  AAK  * R 

IF  ClVV4L.NE.-l»  LVl  AAX  * LVVAL 
R « LVl  AAK 
LVVTP  = LVVAl 


SEHANT81 
SEHANTft? 
SEMANT  83 


SEmANTAS 

<^FmANT86 

10PSE-ANTA7 

mant  sn 
SF  m4nT  A9 
•■FmANT^O 


SFMANT93 

FEMANT93 

SEMANT94 


> '' 


LVVfiL  = -100 

IF  UVVTP,NC.-1)  CO  TO  3? 

31  rONTINUF 
LVVTYP  = 3 
LVVPOS  = I 
LVINOK  = C 
IVFUNC=  STOP 

LVVflPG?  P 

CftLL  LVriNOa  VTNOX.lv  INOX  ,LVIN0x,L  VI  NOXI 


LVl  AAV  3 

R 

IF  ILVViL .NE. -1) 

LVl  AAV  = 

LVVAL 

LVVTP  s LVVAl 

LVVAL  = -100 

IF  (LVVTP. EQ.-l) 

GO  TO 

39 

P - LVl 

AAV 

r IF(STJ  ,LT,  C .and.  XTkp  .EQ.  «89)  GO  TO  3ft 

1 ITEST=-1 

; 3?  CONTINUF 

, C IF  UNAPY  PLUS  OP  MINUS  PfTUPN 

IS TCKsPITG£T( STACKS  JSTOP I . 15.15) 

[ IFaSTCK  .Nf.  2ft8  .ANO.  ISTCK  . NE . llOl  GO  TO  33 

^ JLASTsPITGfT(STACK(JSTOP) .45.15)-! 

i IFdSTCK  .EQ.  ?8ft)  JLASYs JLAST-1 

I LVVPOS  = JLAST 

[ LVVTYP  s 3 

I LVFUNC*  HOL 

LVVAPG=  STPING 

CALL  LVFIN0(LV?  U.LV?  V.LV?  W.LV?  X) 

LVl  AAK  = STRING 

IF  aVVAL.NE.-l)  LVl  AA<  = LVVAL 

LVl  AA'psLVI  AAtf 

LVVAO=-l 

[ LVVTYPr-1 

LVVPOSsl 

1 LVFUNC=  string 

! LVVAPG=LV1  AAP 

1 CALL  LVOLET 

LVl  AAP  3 LVl  AAK 

LV0EST=  0 

LVl  AAQ  * TYPE! 

LVTYpra)  = 1 

j LVVAlS(I)  » LVl  AAQ 

' ivnerTs  0 

LVVNVL  * 1 

IVFUNC  = string 

LVVAPGrLVl  AAP 

ALL  LVNSPT 

IFfLVVAL.LT.O)  call  L VF X T T (L V V AL ) 

IF  avVAL  .LT.:  ) PfTUPN 
LVVPOS  * J 

LVVTYP  s 1 
LVFUNC*  MOL 

LVVAPG=  STRING 

CALL  LVFiNOfLV?  Y.LV?  7.LV^  0 .L  V^  1) 

LVl  AAV  = STRING 

IF  ILVVAL.NE.-l)  LVl  AAV  = LVVAL 
LVl  A AP  = L VI  AAV 


fE “ANT97 
SFMANT98 
SFMANT99 

^■fmanioo 

sfmanioi 

sf^anio? 

SEMAN103 

SFMAN1C4 


LVVAO=-l 
LVVTYP=-1 
LVVPOS=l 
LVFUNC=  ST 

R ING 

LVVARG=L VI 

call  lvolet 

AAP 

LVl  AAP  s 

LVOEST*  0 

LVl  AAK 

tVl  AAR  = 

TYPE  1 

LVTYPEIl)  s 

1 

LVVALSCl)  = L 
LVOEST*  C 
LVVNVL  = 1 

VI  AAP 

LVFUNC  * 

string 

LVVARG=L VI 

call  lvnspt 

AAP 

TFfLVVAL.LT.O 

1 CALL  LVEXIT(LVVAL) 

IF  <LVVAL .LT .0 

) RETURN 

IFIITEST  ,lT. 
RETURN 

0)  J=J-1 

01  J=J-1 
<♦1 

I ^SHIFT(ST0P*45)  .OP.  SHTFHJ,15) 


33  CONTINUE 

iraTFST  .lt. 

JSTACK=JSTaCK 
STflCK(  JSTACKI 
NTMPrR 

CALL  SLEVFL  tSK  IP) 

JSTAC<=JSTACK»l 
Ps  NTHP 
JLAST  = 1 

IF(J5TOP  .GT.  0)  JLAST  sBITGETCSTACKUSTOP)  15) 
nthp=typei 
jj=jlast 
IF  <8ITGFT  <STA 
$ JJsJLAST-1 
LVVPOS  * 

LVVTYP  = 3 


C<USTAC*n,l5.l5)  .EQ.  418  .ANO.  JIAST 
JJ 


LVFUNC= 
LVVAPG=  S 

CALL  LVFINOIL 
LVl  AAK  3 
IF  (LVVAL.NE. 
tVVTYP  = 3 
LVVPOS  « 1 
LVINOX  s 0 
LVFUNC*  S 

LVVAPG=  LVl 
CALL  LVFINOCL 
LVl  AAP  3 
IF  (LVVAL.NE. 

TYPtl  * 
IF(.NOT.  FLAG 
IFMWTHP.eO.O 
ERRFLG*.TRUE. 
CALL  ERRORC78 
35  CONTINUE 

IF(TYPF1  .GT. 
FUNCeFUNCl 


MOL 

TRING 

V?  ?*LV?  3,LV? 

string 

-1)  LVl  AAiC  B LVVAL 


4*L  V? 


.GT.  1) 


51 


TRING 

AAK 

VINOK,L VINOV«LVINnX,LVINOK) 

LVl  AAK 

•1)  LVl  AAP  « LVVAL 
LVl  AAP 

.OR*  NTHP  .EQ.  3)  GO  TO  35 

OR .NTHP. EQ. 21. ANO. < TYPE  1 .E Q. 0 . OR .TYPEl . 


J) 


2 .OR.  NTYPE  .GT.  1)  GO  TO  38 


1.’9 


SrnftNl  31 
SEH4N132 


IF(TYPF1  .EO.  II  FUNC*FUNC2 
IFfTYPEl  .eO,  2)  FUNC*FUNC3 
LVVPOS  » JLAST 

LVVTYP  = 3 

LVFUNC*  HOL 

l.VVflPG=  STRING 

CALL  LVFINOILV2  6.LV2  7*LV2  8,LV2  9) 

LVl  AAP  = string 

IF  (LVVAL.NE. -II  LVl  AAP  a LVVAL 

LVl  AAK  = LVl  AAP 

LVl  AAS  = LEFT 

tVVTVPa  3 

LVVPOSs  1 

LVDESTa  1 

LVTYPECll  = 0 

LVVALSm  = lpar 

LVVNVL  s 1 

LVFUNC  = LVl  AAS 

LVVAPG=LV1  AAK 

CALL  LVNSRT 

IF  aVVAL  .LT.C  I call  LVFXIT  ILVVALI 
IF  ilvval.lt.o)  return 

LVl  AAK  s L VI  AAP 

LVVTYPs  3 
LVVPOS*  1 

LVOEST*  1 
LVTYPE<U  * 0 

LVVALSill  * FWNC 

LVVNVL  * I 
LVFUNC  = LVl  AAS 
LVVARGsLVl  AAK 

CALL  LVNSRT 

IF  (LVVAL. LT. 01  C A LL  L VE X I T (L VV AL I 

IFfLVVAL.LT.OI  RETURN 

LVVPOS  * J 

LVVTYP  = 3 

LVFUNC*  MOL 

LVVAPG*  string 

CALL  LVFIN0(LV2  AA.LV2  AB.LV2  ACtLV2  AOI 

LVl  AAP  = STRING 

IF  (LVVAL.NE. -II  LVl  AAP  * LVVAL 

LVOEST*  0 

LVTYPEdI  « 0 

LVVALSdl  * RPAR 

LVVNVL  * 1 

LVFUNC  * RIGHT 

LVVARG*LV1  AAP 

CALL  LVNSRT 

IF  (LVVAL. LT. 01  CALL  L VEX  I T (L VV AL I 
IF(LVVAL.LT.0I  RETURN 

38  IFdTEST  .LT.  0 .AND.  STj  .LT.  01  J»J^1 
FLAG*. false. 

return 

39  flag*. FALSE. 

GO  TO  11 

C check  for  correctness  OF  SUBSCRIPTS  AND  00  IHPLTEO  LIST  PARAMETERS 

40  NR*R 


SEMANl  3S 
SFMAN136 
SEHAN137 
SEHAN136 
SEHANl  39 
SEMAN140 
SEMAN141 


LVVTYP  « 3 
LVVPOS  » 1 
LVINOX  « 0 
tVFUNC*  STJ 

IVVARG*  R 

CALL  L Vr INOIL  VINOXtL VINO X«LVINOX«L VI NOXI 
LVl  AAP  = P 

IF  ILVVAL«NF.-1)  LVl  AAP  • LVVAL 
LVVTP  « LVVAL 
LVVAL  s -100 

IF  ilvvtr,eq.-i)  go  to  ll 

P = LVl  AAP 
N0FTA*GrTOINISTR  ( JM 

IFINP  .EQ*  359  «ANO.  NBETA  •NE*  GO  TO  S7 
ALPHA«GETTYP<  $TP IJl ) 

GAHMAs^TRU)/  1 000000 
IF  CNTVPE  .eO.  31  GO  TO  45 

IFINP  .EO.  939  .ANO*  NPETA  ,EO.  01  GO  TO  45 
IF  INP  ,EQ.  3*59)  GO  TO  45 

IFINP  .FQ.  ?1  .AND.  NBETA  .EO.  41  GO  TO  45 

IFINPETA  ,EQ.  0 ♦AND.  NP  .EO#  935)  GO  TO  45 

IFINTYPE  .EO.  2 .AND.  NP  .EQ.  935  .AND.  STPIJ-D  .NE. 

IFCNTYPE  *EQ.  ? .AND.  NP  .EQ.  359  *AN0.  »«ETA  .EO.  0) 

CALL  EPP0RI79,J) 
fPPFLG*. TPUE. 

45  CONTINUE 

TFCGAHMA  «GE.  6 .AND.  NBETA  .EQ.  4)  CALL  EPPOPI75) 
IFIALPHA  .EQ.  3)  GO  TO  46 
N1  sALPHA ♦! 

EPPFLG=. TPUE. 

CALL  ERPOPIAO, TYPEINl) ,J) 

46  IFINPETA  .EQ.  4)  PETUPN 
MAPGS=HAPGS»1 

LVl  AAP  s OPPANO 

LVOEST*  0 

LVl  AAS  s MAPGS 

LVTYPEIl)  » 1 

LVVALSm  s LVl  AAS 

LVOESTs  0 

LVVNVL  * 1 

LVFUNC  * FUNC^ 

LVVAPGsLVl  AAP 

CALL  LVNSPT 

IFILVVAL.LT.C)  call  LVEXITILVVAL) 

IF  ilvval.lt.o ) return 

LVOESTs  0 

LVl  AAK  » J 

LVTYPEIl)  = 1 

IVVALS  11 ) s L VI  AAX 

LVOESTx  0 

LVVNVL  * 1 

LVFUNC  s FUNC3 

LVVAPGsLVl  AAP 

call  LVNSPT 

IFILVVAL.LT.C)  CALL  LVEXITILVVAL) 

IFILVVAL.LT.C)  RETURN 
LVOESTs  0 


-7)  GO  TO 
CO  TO  11 


SEHAN143 
SEHAN144 
SE NANI  45 
SENAN146 
Sf  NAN147 
SE NANI  46 
SEHAN149 
SENAN150 
SEnANISI 
45SENAN15? 
SE“AN155 
SEMAN154 
SENAN155 
^E«A  N156 
Sf NAN157 
Sf NAN15S 
Sf NAN159 
5f  HAN16C 
SE*»AN161 
•“f  **AN16? 
SfN|N1^3 


AAT 


LVl  AAT  « NOEPTH 
LVTVPEai  = 1 

LVVALS  * LVl 
LVOEST*  0 
LVVNVL  « 1 

LVPUNC  = LEVEL 

LVVAPGsLVl  AAP 

CALL  LVNSRT 
IF CLVVAL.LT.C ) call  LVEXIT  ILVVAL) 

IF  aVVAL*LT,OI  9FTUPN 
IVRs(HAPGS*?>/3 
IFfIVR  .GT,  50>  GO  TO  1610 
ICOL»20*MOO (marge -1,3) tlO 
IVAL=H00(STR(J), 10000) 

rARGS(ivR)snrrpuT(iARcs(  ivr> ,i val*icol) 

IF (NR  .EQ.  639)  GO  TO  49 
IF(NTYPE  .NE.  3)  RETURN 
C flag  SUBSCRIPT  IN  I/O  LIST 

lAPGS ( IVR) sBI TPUT (lARGSI IVR) ,1 , ICOL^S) 

RETURN 

C P^LAG  00  INDEX  IN  I/O  LIST 

4 9 IARGS(IVR)=eiTPUT(IARGS(  IVR)  , ? , ICOL^S  ) 

IF(NFLAG  ,LT.  1)  RETURN 

lARGSI IVR) =01  TPUT (IARGS( IVR) , F U NFL AC ) , I COL ♦ 10  » 

RETURN 
4 7 NR  = R 

C SUBSCRIPT  DOES  NOT  BEGIN  WITH  CONSTANT,  FORCE  SEARCH  FOR  VARIABLE 
GO  TO  11 

C CHECK  FOR  PROPER  NUMBER  OF  SUBSCRIPTS 

SO  IFI  beta  .EO.  4 .OR.  R .NE,  4S?)  GO  TO  5? 

MARGS=MARGS^1 

LVl  AAP  s OPRANO 

LVOESTs  0 

LVl  AAU  s MAPGS 

LVTYPE(l)  s 1 

LVVALS(l)  = LVl  AAU 

LVOESTs  0 

LVVNVL  = 1 

LVFUNC  = FUNC? 

LVVAPG=LV1  AAP 

CALL  LVNSRT 

IFCLVVAL.LT.O)  CALL  LVEX I T (L VV A L ) 

IF  (LVVAL.lt, 0)  RETURN 

LVOESTs  0 

LVl  AAV  » J-1 

LVTYPE(l)  = I 

LVVALS(l)  » LVl  AAV 

LVOESTs  0 

LVVNVL  = I 

LVFUNC  s FUNC3 

LVVAPGsLVl  AAP 

call  LVNSRT 

IF(LVVAL.LT.O)  CALL  LVEXIT  (LVVAL) 

IF  (LVVAL. LT.O)  RETURN 
LVOESTs  0 
LVl  AAH  s NOEPTH 

LVTYPE(l)  * 1 


I 


SEMAN16S 
CYE8B  5 
SEHAN166 
SEHAN167 
SEHAN166 
SEHAN169 
SEHAN170 
SEMAN171 
SEMAN172 
SEMAN173 
SEMAN174 
SEMAN175 
SEMAN176 
SEMAN177 
SEHAN178 
SEMAN179 
SEMAN180 
SEMAN161 
SEMAN162 
SEMAN183 
SEMAN164 


LVVALS  m = LVl  AAM 

LVDESTs  0 

LVVNVL  = 1 

LVFUNC  = LEVEL 

LVVAPG=LVl  AAP 

call  LVNSRT 

IF(LVVAL.LT,C»  call  LVfJfrKLVVALI 

IFCLVVAL.LT, Cl  RETURN 

IV0sCHARGS*3)  /3 

IF  (IVR  . GT.  50  I GO  TO  1610 

ICOL=2C*MOO(Mft9GS-l,3) ♦lO 

TVALsHOOCSTRCJ -II  , 10  00  0 

lAPGS (IVRIsOITPUT  C I APG5 C I VRI  , I V AL , I COL) 

IFCNOPAR  .LE.  Cl  GO  TO  5? 

LVVPOS  s 1 

LVVTYP  = 3 

LVVPOSs-LVVPOS 
LVFUNC=  ACTION 

LVVAPG=  OPPANO 

CALL  LVFlNOILVa  A£,LV?  AF,LV?  AG,LV?  Al- 

LVl  AAP  = OPRAND 

IF  CLVVAL.NE. -II  LVl  AAP  = LVVAL 

LVVTR  = LVVAl 

LVVAL  = -100 

IF  CLVVTR.EO. -1)  GO  TO  52 

MFUNC  = LVl  AAP 

lARGS  ( IVR)=*U  TPUT  (lAPGSC  IVRI  ,NFUNC  , ICOL  ♦I) 
lARGSC IVR) =BI  TPUT  IIARC5I IVRI  ,NAPGSt ICOL^  9) 

C IF  NO  STRING  L^’FT,  RETURN  IF  C ONST  A NT  , V A R I AR  LE  OR  I/O  LIST 
52  IFCSTJ  ,LT.  C .AND.  I5ETA  .EO,  C .OR,  RETA  , EQ . ** 

$ .OR.  NTYPE  .EQ.  31)  RETURN 
IF  (BETA  .GT,  NARRAYI  GO  TO  55 
frpFLG=, TRUE. 

CALL  ERR0P(51,J) 

55  IFfP  .fO,  4521  NARRAYsO 

IFCR  ,EQ,  318)  NARRAYsl 
IFfP  ,E0,  601  NARRAYs? 

IFfP  ,EQ.  1031  NARRAYS3 
IFfSTJ  ,LT,  C)  GO  TO  58 
LWTYP  s 3 

LVVPOS  = 1 
LVINOY  = C 
LVFUNC=  STJ 

lvvapg=  r 

CALL  LVFINOfL  VINO  *,L  VINO*,  LVINn)r,LV  INOX) 

LVl  AAP  * P 

IF  CLVVAL.NE. -1)  LVl  AAP  = LVVAL 
R s LVl  AAP 
LVVTR  = LVVAL 

LVVAL  * -no 

IF  ILVVTR.NE.-1)  GO  TO  56 

58  IFCNTYPE  .EO.  3 .ANO.  NARRAY  ,EO.  01  GO  TO  57 

IFfBETA  ,GE,  1 ,ANO,  SETA  ,LE,  3 ,AN0.  NOPAR  . EO.  0) 

• CALL  FRROR(82,J) 

57  NARPAYs-1 
GO  TO  11 

56  IFfNTYPE  .EO.  3 ,ANO.  NARRAY  ,EQ.  01  RETURN 


SEHAN186 
CY'^SR  6 
SEHAN187 
fe«AN1 88 
SEMAN189 
SEHAN19C 


SFHAN192 
SEMAN193 
SEMAN194 
5FMAN195 
SFMAN196 
SFMAN197 
'^Ehan198 
SFHAN199 
SFMAN300 
SEhan?01 
Sf MAN?02 
SFHAN203 
SEHAN204 


SFMAN206 

5FMAN?J7 

SEMAN208 

SE>*AN309 

SEMAN?10 

SEman?11 


1 


IFCSTJ  .EQ.  9P40  •ANO.  NAPRAY  ,LT.  PETA  .AND,  J .EO*  MAXJ)  <■EHAN^1^ 

$ CALL  EPROR<^‘?,J)  ?E«AN213 

TF(STJ  ,EQ.  RPAP)  NARRAYs-1  SEHAN2l<* 

RETURN  *=:EHAN215 

C RES^’T  TYPE  OF  STATEMENT  IN  A NT  IC  I PA  T ION  ‘ OF  SEARCH  FOR  BOOLEAN  PRI  MAP  YSE  HA  N21  6 
60  CONTINUE  SF*-AN217 

NOTFlGs. false.  SEMAN218 

IFISTRU-1)  .EQ.  -171  N0TFLG  = . TRUE.  SEHAN219 

TYPEls-l  SEHAN220 

LVVPOS  = J 

LVVTYP  s 3 
LVFUNC=  MOL 

LVVARG=  string 


CALL  LVFINO(LV2  AT.LV2  AJ.LV2  AK,LV2  AL» 

LWl  AAP  = STRING 

IF  (LVVAL.NE.-l)  LVl  AAP  = LVVAL 

LVl  AAX  = LVl  AAP 

LVVAO=-l 

LVVTYP=-l 

LVVPOS=l 

LVFUNCs  string 
LVVARG=LV1  AAX 

CALL  LVOLET 

LVl  AAX  = LVl  AAP 

LVOEST=  0 

LVl  AAY  = TYPFl 

LVTYPEdI  = 1 

LVVALS  Cl»  = . VI  AAY 

LVDEST=  C 

LVVNVL  = 1 

LVFUNC  = STRING 

LVVARG=LV1  AAX 

CALL  LVNSRT 

IF!LVVAL.LT,0»  call  LVFXIT (LVVAL) 


IF  (LVVAL 

.LT.O)  RETURN 

IFfSTJ  . 

NE.  OPPAND)  GO 

TO  66 

SEMAN222 

ALPHAsGETTYP(STR( J)) 

SEMAN223 

R£TA  = GET0IM(STR( J)  ) 

SEMAN224 

IF (ALPHA 

.NE.  4)  GO  TO 

11 

SEMAN225 

66  CONTINUE 

Sf MAN226 

LVVTYP  = 

3 

LVVPOS  = 

1 

LVINHX  5 

0 

LVFUNC= 

ST  J 

lvvapg= 

R 

CALL  LVFINOCL VINO X,LV INOX, LVINOX.LVINOX) 

LVl  AAP  s p 

IF  fLVVAL.NE.-l)  LVl  AAP  = LVVAL 
LVVTP  » LVVAL 
LVVAL  = -100 

IF  fLVVTR.EO.-l)  GO  TO  11 

R = LVl  AAP 

RETURN  SEMAN228 

C IF  BOOLEAN  PRIMARY  IS  AN  ARETHMETIC  COMPARE  CONTINUE  PARSING  PRIMARY  SEMAN229 

70  IFfSTj  .LT.  0)  RETURN  SEMAN230 

IFfTYPEl  .EO.  4)  GO  TO  76  SEMAN231 

LVVTYP  » 3 


1 i'. 


LVVPOS  » 1 
LVINOX  s 0 
LVFUNC*  STJ 

LVVARG=  R 

CALt  L VFINO<L  VINPX,  LVINOX,  LVINOX,  L VI  NO  XI 
LVl  AAP  s R 

IF  ILVVAL.NE.-n  LVl  AAP  = LWAL 
R = L VI  AAP 
LVVTR  = LWAL 
LWAL  = -130 

IF  (LVVTR, EO.-l)  GO  TO  11 

relational  operator  found 

IFINOEP  .EO,  0)  RETURN 
LVVPOSs-L  WPOS 
LVVTXPs  3 
LVVPOS=  1 

LVPfST=  2 
LVl  AAP  = 1 

LVTYPEdl  = 1 

IWALS(l)  = L VI  AAP 
LV0EST=  2 
LVVNVL  = 1 

LVFUNC  s FUNCl 

LVVAPG=  OPRANO 
CALL  LVNSRT 

IF(LWAL.LT,3)  call  LVeXITiLVVALI 
IF  ILVVAL.LT ,3 ) RE  TU»N 
R£  TURN 

IF  nOOLEAN  VAOIARLE  OP  CONSTANT,  SET  STATE  TO  STOP 
75  psFTOP 

JSTACX= JSTACX^l 

ST  ACK(  JSTACK)  =SHTFT  (P,i*5l  .OP.  SHIFT  ( J,l 
GO  TO  11 

COMPARE  types  ON  POTH  SIDES  OF  RELATIONAL  EXPRESSION 
50  IFITYPEl  ,fq,  0 .OR.  TYPEI  , EO . 2 .OR.  TYPEl  .EO.  3)  GO  TO  85 

errflg=. true. 

CALL  ERROP(8T,Jl 
TYPE1=-1 

LVVPOS  * J 

LWTYP  = 3 

LVFUNC*  HOL 

LVVARG=  string 

CALL  LVFIN0(LV?  AH,LV?  AN,LV?  AO.LV? 

LVl  AAX  = string 


SEMANP33 

SFmAN?34 


<‘FHAN?36 

SFmAN?37 

SFMAN238 

SFMAN230 

«‘FHAN?4C 

SFHAN?41 

*‘FMAN?4? 

SFhan?43 

**EMAN?44 

SFMflKj?(*5 

^FMAN?46 


HOL 

string 

LV?  AH,LV? 

string 


IF  (LVVAL.NE.-l)  LVl  AAX  = LWAL 

LVl  AA7  = LVl  AAX 

LVVADs-1 

L WTYP  = -1 

LVVPOS*! 

LVFUNC*  string 
LVVARG=LV1  AA7 
CALL  LVOLET 

LVl  AA?  r LVl  AAX 

LVDFSTs  <3 
LVl  AAO  * TYPFl 

LVTYPEdl  = 1 

LVVALS(I)  * LVl  AAO 


LvnesT=  G 

LVVNVL  = 1 

LVFUNC  = string 

LVVAPG=LV1  flfl7 
CALL  LVNSRT 

iraVVAL.LT.C)  call  LVFXTTaVVAL) 

IF  CLVVAL .LT ,C  I RFTURN 
AS  TYPF?-TVPF1 
GO  TO  11 

SOOLFAN  PFIMARY  RECOGNI7FO-SFT  TYPE  TO  SOOUFAN  ANO  CONTiNtF  PARSF 
93  TF<TTPF1  .FQ.  TYPE3  .OP.  Typfi»TYPF2  .FQ.  ? .OR. 

♦ TYPE?  .LT.  Cl  GO  TO  9S 
Nl=TYPfl*l 
N?=TYPE2^1 

CALL  EPP0R(7?,TYPE(N1I  ,TYPECN?n 
ERRFLG=. true. 

95  TYPElsU 
TYPE2=-1 

IFfSTj  .LT.  0)  RETURN 
LVVPOS  = J 

LVVTYP  X 3 
LVFUNCx 
LVVARGx 

CALL  LVFINOILV?  AO.LV?  AR,LV3  AS  .L  V2  AT) 

LVl  AAY  X 


$EMAN?48 

SFMAN249 

SFHAN250 

SFMAN251 

SFH4N2S2 

SFMAN253 

SEHAN254 

SEHAN255 

fFHAN256 

SFHAN2S7 

SFMAN2S8 

SFMAN259 


HOL 

string 

AO,LV2 

string 


LVl  AAX  = LVVAL 
AAV 


IF  <LVVAL.NE.“1) 

LVl  AAZ  X LVl 
L VVADx-i 
LVVTYPx-i 

LVVPOSxl 

LVFUNCx  STRING 
LVVARGxLVl  AA7 
CALL  LVOLET 

LVl  AA7  X LVl  AAX 

LVPFSTx  0 

LVl  AAl  = TYPEl 

IVTYPF(l)  X 1 

LVVALS<n  X LVl  AAl 

LVDFSTx  C 

LVVNVL  = I 

LVFUNC  X STRING 

LVVACGxLVI  AA7 

CALL  LVNSRT 

IF  (LVVAL. LT. Cl  call  LVFX  IT  (L  WAL  I 
IF  (LVVAL .LT. 01  RFTUPN 

GO  TO  11  rFMAN261 

PARSE  REACMEO  RLINO  ALLEY-MUST  PACK  UP  ANQ  REMOVE  PARENTHESES  CRF  ATE0«^F«AN252 
99  9 JMxRiTf.FKSTACK  ( JSTAftf  ) ,4S,IS»  SFMAN26  3 

<»JM  SFHAN254 

00  996  KKxJM.J  ^TMANZeS 

LVVPOS  X K 

LVVTVP  = 3 

LVFUNC*  MOL 

LVVAPGx  string 

call  LVFIN0(LV2  AU,LV2  AV,LV2  AW,LV2  AX» 

LVl  AAX  r string 

IF  (LVVAL.NF.-tl  LVl  AAX  x LVVAL 


ih 


w 


LVVTR  r LVVAL 
LVVAL  = -100 
IP  UVVTP.€Q.-n  GO  TO 
LVVPOS  = I 

LVVTYP  = 3 

LVFUNC=  string 
LVVAPG-  LVl  AAX 
CALL  LVriNOaV?  AY,LV? 

LVl  AA?  = LVl  AA* 

IF  ILVVAL.NE.-l)  LVl  AA? 
LVVTP  s LVVAL 
LVVAL  = -100 
IF  (LVVTR.EQ.-l)  GO  TO 
TYPFl  2 LVl  AA7 

GO  TO  995 
996  K=K-l 
995  CONTINUF 

00  998  I2JH,J 
LVVPOS  = I 

LVVTYP  s 3 
LVFUNC=  HOL 

LVVAPG=  string 

CALL  LVPINOaV?  A7,LV2 

LVl  AA?  s string 

IF  ILVVAL,NF,-1)  LVl  AA? 


LVl  AAX  s LVl 
LVVAO=-l 


AA? 


L VVTYPe-1 
L VVPOS=l 

LVFUNCs  LEFT 

LVVAPG=LV1  AAX 

call  LVOLET 

LVl  AAX  s LVl  AA? 

LVVADs-l 

LVVTYP2-I 

LVVPOS2I 

LVFUNCs  RIGHT 

LVVAPG=LV1  AAX 

CALL  LVOLET 

P98  continue 

980  continue 

LVVPOS  s 1 

LVVTYP  s 3 
LVVPOSs-LVVPOS 
LVFUNCs  FUNC3 

LVVAPG*  OPPANO 

CALL  LVFINOaV?  A6.LV? 

LVl  AA?  s OPPANO 

IF  (LVVAL .NE.  - 1)  LVl  AA? 

JN  s LVl  AA? 

IFIJN  ,LT*  JH)  CO  TO  985 
LVl  AA?  s OPPANO 

LVVPOS  = 1 

LVVTYP  s 3 
LVVPOSs-L VVPOS 
LVFUNCs  FUNC? 

LVVAPGs  LVl  AA? 


A?,LV? 
L VVAL 

996 


A3,LV2 

LVVAL 


A7,LV2 

LVVAL 


AOtLV?  Al) 


A(*«LV?  A5) 


A8.LV2  A9) 


1 17 


SEHAN26? 

«^EMAN?68 

SEHAN269 

SEHAN27C 


SEHAN272 


SEMAN274I 


LVVflO=-l 
CALL  LVOLET 
tVVPOS  = 

LVVTYP  * 3 

LVVPOS=-L VVPOS 
LVFUNC*  FUNC3 

CVVflPC=  LVl  AAZ 
L VVftO*-l 
CALL  LVOLET 
LVVPOS  = 

LVVTYP  = 3 

L VVPOSs-L VVPOS 
LVFUNC= 

LVVARG*  LVl 
LVVA0=“1 
call  LVOLET 
GO  TO  990 
995  CONTINUE 


LEVEL 

AAZ 


SEMANZ76 


LVVPOS  s 
LVVTYP  s 3 

LVVPOS=-LVVPOS 

1 

LVFUNC=  FUNC2 

LVVARG2  OPRANO 

CALL  LVFINO(LV2 

BA,L 

V? 

B6,LV? 

LVl  AAZ  2 

OPRANO 

IF  (LVVAL. NE.-l) 

LVl 

AAZ  2 

LVVAL 

MARGS  2 LVl 

AAZ 

LVVPOS  2 
LVVTYP  2 3 

LVVPOS=-L VVPOS 

1 

LVFUNC=  LEVEL 

LVVAPGs  OPRANO 

CALL  LVFINO(LV2 

8E,LV2 

BF,LV? 

LVl  AAZ  s 

OPRANO 

IF  (LVVAL. NE.-l) 

LVl 

AAZ  2 

LVVAL 

NOEPTH  2 LVl 

AAZ 

BC  *L  V2 


BO) 


8G«L  V? 


BH) 


RETURN 


C RECOGNIZEO  FU)C  T I ON- PREPARE  TO  SET  TYPE  OF  ARGUMENTS  FOR  THE 
C FUNCTION  IN  THIS  STMT 

1000  CONTINUE 

N0EPTH=N0EPTH^1 

NOEPsNOEP^l 

NARGS-0 


LVVTYP  = 
LVVPOS  * 
LVINOX  s 
LVFUNC* 
LVVARG= 


FEHAN279 
SEmA  N?flO 
•N0EPTHrEMAN261 
SEHAN292 
SEMAN293 
SEMAN?9*» 
SEMAN285 
SEMAN296 


ST  J 
R 


CALL  L VFINO (LVINOX, L VINO X, LVINOX « LVINOX) 


LVl  AAZ  > 

IF  (LVVAL.NE.-l) 
LVVTR  2 LVVAl 
LVVAL  * -100 
IF  (LVVTR.EQ.-1) 
R » LVl 

NARGS*! 


AAZ 


LVVAL 


GO  TO 

AAZ 


11 


SEMANZSe 


OPPiNO 


LVl  447  = 

LVOeST*  0 
LVl  44X  a TtPEl 
LVTvpeai  a I 
LVV4LSU)  = LVl  44X 

LVOfSTa  C 
LVVNVL  = I 
LVFUNC  a OPR4NO 

LVV4ffG=LVl  447 

C4LL  LVNSPT 

1F(LVVAL.LT,QI  call  LVeXITtLVVALI 

TF  (LVVAL.LT.C I RFTURN 

LVOESTa  C 

LVl  44?  a NAPGS 

LVTYFEin  = 1 

LVVALS  a»  = LVl  44? 

LVDFSTa  0 
LVVNVL  = 1 

LVFUNC  a STRING 

LVVAPGaLVl  447 

CALL  LVNSRT 

IF  (LVVAL.LT.C)  call  LVEXIT<LVV4L» 
IF  aVVAL.LT.C)  RFTURN 

LVOESTa  Q 

LVl  443  a nOEPTH 
LVTYPEtn  a 1 
LVVAlS  111  a LVl  443 

LVOESTa  0 
LVVNVL  a 1 
LVFUNC  a 4CTION 

LVVAPGaLVl  447 

CALL  LVNSRT 

IF  (LVVAL.LT*C)  call  LVFXITCL VV4LI 
IF  IL VVAL .LT.C I RETURN 

LVOESTa  C 

LVl  447  a 0 
LVTVPEin  a I 
LVVALSIl)  a LVl  447 

LVOESTa  0 
LVVNVL  a 1 
LVFUNC  a FUNCl 

LVVARGa  OPRANO 
CALL  LVNSRT 

IF  IlVVAL.LT.O I call  LVFXIT  (LVV4LI 

IF (lvval .lt.ci  return 


TVPEla-l  SFM4N?91 

NOPACaNOPAP*!  SEHAN?9? 

RETURN  SEM4N?93 

SfMflN?9<. 

C KEEP  TRACK  OF  the  NUNQER  ANO  TtPES  OF  ARGUMENTS  IN  FUNCTION.  CALLS  SfMftN?9S 

C MUST  USE  STACK  FOR  POSSIBLE  RECURSIVE  FUNCTION  USE  SEM4N?96 

1 103  CONTINUE  SEM4N?97 

LVVTTP  a 3 
LVVPOS  a 1 
LVINOK  * 0 
LVFUNCa  STJ 


LVVApGs  R 


AA4  : LVVAL 


GO  TO 
AA(* 
OPPANO 
1 


RI  *LV? 
AAA 
LVl  AA5 


BJ.LV3 


L VVAL 


CAUL  LVP  INO  (LVINOX.L  VINf)*,l.VINnx,LVlNOX) 
LVl  AAA  s P 

IF  (LVVAL.Nf.-l)  LVl 
LVVTP  = LVVAL 
LVVAL  s -100 

If  (LVVTP. eo.-l)  GO  TO  11 

P = LVl 
LVl  AAA  : 

LVVPOS  s 
LVVTVP  5 3 

LVVPOSs-LVVPOS 
LVFUNC=  string 
LVVAPG*  LVl  AAA 
PALL  LVFIND(LV? 

LVl  AA5  » L VI 
IF  (LVVAL .Nf. - 1)  LV 
LVVTP  2 LVVAL 
LVVAL  2 -100 

IF  (LVVTP. EQ.-l)  GO  TO  1103 

NAPCS  = LVl  AAf 

LVVPOS  2 
LVVTVP  s 3 
LV VPOS2-LVVPOS 
LVFONC2  STRING 

LVVAPG2  LVl  AAA 
LVVAn=-l 
CALL  LT/OLfT 
LVVPOS  = 1 

LVVTVP  2 3 

LVVPOS=~L VV^OS 
LVFUNC=  ACTION 

LVVAOGs  LVl  AAA 

CALL  LVFINOfLV?  PN,LV2  BN.LV? 

LVl  AA5  2 LVl  AAA 

IF  (LVVAL. Nf.-l)  LVl  AA*>  2 LVVAL 
MFUNC  2 LVl 
LVVPOS  2 
LVVTVP  2 3 

LVVPOS2-L VVPOS 
LVFUNC=  FUNCl 

LVVAPGs  OPPANO 

call  LVFrlVO(LV^  PO.LV?  PP.LV? 

LVl  AAA  2 OPPANO 

IF  (LVVAL. NE. - 1)  LVl  AAA  2 LVVAL 
AAA 


RK  .L  V? 


BL> 


1 


1 


RN,l  V2 
AAA 

LVl  AA*>  2 
AA^ 

1 


BO  .L  V? 


RP) 


BS  .L  V? 


BT) 


If XP  2 L VI 
110  3 continue 
C STOPF  ARGUMENT  TVPES 
rF(NOfPTM  .GT.  5> 

TF  (NOEPTH  ,GT  . 5 » 

IF  (NAPGS  .Lf.  G3)  GO  TO 
PpPFLG*. TPUf. 

CALL  f ppOP(«A,NOFPTH) 

GO  TO  11 
IICA  CONTINUF 

hH2 (II ♦NAPGS) /6 
IT FMPsNAPGS-6 • (MH-?) 
rCCL^B'ITf  MP-6 


call  FPP0P(^5) 
GO  TO  11  30 
llOA 


‘‘fMANTCl 

«T*-An30? 

SEMAN3CA 
<‘F“ani:s 
SF«An30E 
*‘F“AN337 
SF^'An30« 
<T«AN.TCB 
Sf mantio 
SF-AN311 
SEHAN31? 


-♦() 


Nftpy  t HPUNC  ,MH  ) TPUT  (NA  PY  (HP'iNC  , M«)  , NQ3  ( ( T Y P€  1*1)  ,P.)  , ICOt  ) 
IPCSTOIJ-?)  .NF.  -6  .ANO.  «;T0(J-2I  ,Nf,  -4)  GO  TO  1130 
NOlMsr.FTOlHfSTPlJ-D) 

IP  INTI  M ,GP.  4 ) CO  TO  1130 
C STOPE  OMENSIONAl  ITY  OP  APGUHFNTS 

NAPYMPUNC  ,HH)  sRITPUT  (NAPY(  HPUNC  « HN  I H 0 1 H , IC  a * 3 1 
1133  rONTINUP 

NAPVfMPUNC  ,HH)=«TTPUT(NAPV<mciJNC  ,MH),IEXP»P4*IT^HP) 

IPiSTJ  .EQ.  COMHA)  go  to  1105 

KAPY  (HFUNC.l)  sNAPGS 

IVl  AA4  * OPPANO 

LVVPOS  r 1 

LVVTvp  « 3 

LVVPOSs-L VVPOS 

LVFL/NCs  action 

LVVAPC=  tVl  AA4 
LVVAO*-! 


CALL  LVOLET 
LVVPOS  5 

LVVTYP  5 3 

LVVPOS=-L VVPOS 
IVPUNCs  OPPANO 

LVVAPG=  LVl  AA4 
TALL  LVPINOiLV? 

LVl  AA5  s LVl 

IF  ILVVAL.NE.-I)  L 
LVVTP  s ivval 
LVVAL  = -IOC 
IP  <LVVTP.EO.-l» 
TYP£1  s LVl 
LVl  AA4  s 

LVVPOS  = 

LVVTYP  s 3 
LVVPOS  = -L  VVPOS 
LVPUNC*  FUNCl 

LVVAPG*  LVl  AA4 
LVVAOs-I 


eU,LV?  RV.LV? 

AA4 

1 AA5  = LVVAL 


GO  TO 
AA«> 
OPPANO 
1 


1135 


PN  .L  V? 


0X) 


call  lvolft 

LVVPOS  * 1 

LVVTYP  * 3 

LVVPOS* -L  VVPOS 
LVFUNC*  OPPANO 

LVVAPG*  LVl  AA4 
LVVAOs -1 

call  LVOLFT 

1135  NOPAPsNOPAP-1 
NOFP*NOEP-l 
PE  TUP N 

1105  TYPEla-l 

LVVPOS  s J 

LVVTVP  r 3 
LVPUNC=  HOL 

LVVAPG*  STRING 

call  LVPINOILV?  0Y,LV^  R?»LV3  ROtLV?  Rll 

LVl  AA4  8 STRING 

IP  (LVVAL  .NF. - 1)  LVl  AA4  = LVVAL 
LVl  AA5  8 LVl 


rvfO  ^ 

SF-AN314 
‘‘f  *-AN315 
SE“AN316 
SF«AN317 
<‘F**AN318 
SF*-AN319 
^FwAN370 
SF-ANSai 
'•FMAN32? 


SFMAN325 

SFMAN326 

SFMAN327 

SEMAN328 


k. 


AA4 


}k 


r 


LVVflC= -1 
lvvtyp=-i 


L VVP0S=1 

LVFUNC=  STPING 
LVVfiPG=LVl  flftS 

CALL  LVOLET 

LVl  4fl5  = LVl  Afl*. 

LVPFST=  0 

LVl  AA6  = TYPFI 

LVTYPE(l)  = 1 

LVVAlS  n ) = L VI  AA6 

LVOFETr  C 

LVVNVL  = 1 

LVFUNC  = string 

LVVACG=LV1  AA5 

call  lvnspt 

IF  (LVVAL.lt. 0 > call  LVrxiT  (LVVAL) 

IF  (L VV AL .L T.c ) RETURN 

NARGS  = NA£?GS^1 

LVP‘^ST=  0 

LVl  AA4  = NARGS 

LVTYPEd)  = 1 

LVVALS  (1 ) = L VI  AA4 

LV0EST=  0 

LVVNVL  = 1 

LVFUNC  = string 

LVVAPG=  OPRAND 

CALL  LVNSRT 

if  CLVVAL  .LT  .0 ) CALL  L VF X I T <L V V AL 1 

IF(LVVAL.LT.0I  RETURN 

LVVPOS=-LVVPOS 

lvvtyp=  3 

LVVPOS=  1 

LVOESTr  2 

LVl  AA5  = 0 

LVTYPE(l)  = 1 

LVVALS (II  = LVl  AA5 

LVOEST=  2 

LVVNVL  = 1 

LVFUNC  = FUNCl 

LVVAPG=  QPRANO 

CALL  LVNSRT 

IF(LVVAL.LT.C)  call  LVFXIT(LVVAL) 
IF(LVVAL.LT.0I  return 
RF  TURN 


C SAVE  type  of  STAEHFNT  WHILE  PARSING  EXPONENT 
l'»00  CONTINUE 

J 
3 

HOL 
STRING 

B2*LV?  B3*LV2 

string 

LVl  AA7  2 LVVAL 

AA7 


LVVPOS  = 

LVVTYP  s 
LVFUNC* 

LVVAPG* 

CALL  LVFTNOCLV^ 
LVl  AA7  = 

IF  (LVVAL. NE. -II 
LVl  AAfl  s L VI 

LVVAO=-l 

LWTYPr-i 


B4  .L  V? 


BSI 


SEHAN330 


SEHAN333 

SFMAN334 

SF“AN335 


I 


w 


LVVPOSsl 

LVFUNC= 

ST  R ING 

LVVaPG-L  VI 

aae 

raLL  LVOLET 
LVI  aa<s 

= LVI 

aa7 

LVOFSTs  c 
LVI  aaq 

= TYPFl 

LVTYPECD  = 

1 

LVVaLSCll  s 

- VI 

aaq 

LVOFST=  0 

I : 


LVVNVL  = 1 

LVPUNC  = STRING 

LVVflOG=LVl  aft^ 


raiL  lvns»t 
IF  <L VVfiL .LT.r  > 
IF (LVVflL.LT.C) 
TYPF1=-1 
LVVTYP  = 3 
LVVPOS  s 1 
LVINOX  = C 


CfiLL  I VFXITavvaL) 
RFTUPN 


LVPUNC=  STJ 

P 

CatL  L VFINOd  VINO  X,LVINOX,LV  INHX.L  VINO  X) 

LVi  aa?  = p 

IF  <LVvaL.NE. -1)  LVI  aa7  a LVVai 
IVVTP  = LVVaL 

ivvai  s -100 

IF  (LVVTO.EO.-l)  GO  TO  11 

p = u VI  aa  7 

Pf  TUPN 
CONTINUF 

IPISTJ  .LT.  C)  PFTUPN 

iP(STj  ,nf,  aNO  .aND.  STJ  .ne.  op  .ano.  stj 

LVVTYP  = 3 
LVVPOS  r 1 
LVTNPX  = 0 


c 


LVPUNC=  STJ 

LVVaPGs  P 

raLL  LVPlNn(LVINOX,LVINOX,LVINnx,LVTNOX) 

LVI  aa7  = p 

IF  <LVvaL.NE.-i)  LVI  aa7  r LVvaL 
lvvtp  = LVvai 
LVVaL  s -103 

TP  ILVVTP.EO.-l)  GO  TO  11 

p s LVI  aa7 
IF  <NntP  .FO.  0)  PETUPN 
LOGICaL  OPPPaTOP  FOUND 
L VVPOS=-L VVPOS 
LVVTYPff  3 


L VVPOSs 
LVOFSTs  2 
LVI  aa7  = 1 
LVTyPE  Cl ) s 1 
ivvaLS<i)  = .VI 
LVOESTr  2 
LVVNVL  = 1 

LVPUNC  ? 


aa7 


.NE.  NOT)  GO  TO  11 


SE-aN337 


*‘F«aN33q 

«‘E“aN34l 

‘‘FMflN342 


SE«aN3^‘. 

SF**aN3u5 


FUNCl 


LVVAPGs  0P9AND 

tall  lvnspt 

TF <lvval,lt,o)  call  lvfvitilvval) 

IF  a VVAL  .LT ,c ) RF  TURN 
R£  TURN 

lUOO  CONTINUF 

LVVTVP  = 3 
LVVPOS  * 1 
LVINOX  = 0 
LVFUNCs  STJ 

LVVARG=  R 

CALL  L VFINDCL VINnx,L VlNnx,LVlNnx,LVINOXJ 
LVl  AA«  s p 

IF  (LVVAL.NF.-l)  LVl  AA9  * LVVAL 
LVVTP  = LVVAL 
LVVAL  = -100 

IF  ILVVTP.EQ.-1)  GO  TO  11 

R * L VI  AA8 

C LEFT  PAREN  FOUNO  IN  I/O  LIST 

nflag*nflag^i 
FL (NFLAG)-HARGS 
RETURN 

isoo  continue 

LVVTYP  = 3 
LVVPOS  = 1 
LVINnX  r 0 
LVFUNC=  STJ 

lvvapg=  P 

CALL  LVFtNO (L  VIN0X,LVTN0X,LVINQX,LVIN0X) 
LVl  AAA  = R 

IF  «LVVAL.NE.-1)  LVl  AAA  = LVVAL 
LVVTP  s LVVAl 
LVVAL  = -100 

IF  (LVVTP. EO.  -1)  GO  TO  11 

R = LVl  AAA 

IF/STJ  .EQ.  COHMA)  return 
C right  PAPFN  found  in  I/O  LIST 

NFLAGsNFlAG-I 
pp  TURN 

1601  continue 
typei  = <* 

PF  TURN 

1610  call  EPR0P<SE) 

•“TOP 
PF  TURN 

?S:0  0 CONTINUE 


<:FmAN349 

SENAN350 

SFMAN351 

SFHAN352 


SEMAN364 
?f NAN355 
EEMAN356 
EFMAN357 
SFMAN35A 
SFHAN359 
CYSefl  7 
CVSAP  A 
CY«-8R  9 


LV2 

A=LV? 

8»LV? 

C*LV? 

o=c 

LV? 

E = LV? 

f*lv? 

g*lv? 

H»  0 

LV2 

I=LV? 

J = LV? 

K = LV? 

L = 0 

L V? 

MrLV? 

N*LV? 

0*LV? 

Pc  0 

LV? 

0 = LV? 

P=LV? 

S = LV? 

T=0 

LV? 

U = LV? 

V*L  V? 

W*L  V? 

x*0 

LV? 

Y = LV? 

?sLV? 

Q=LV? 

1 = 0 

LV? 

?=LV? 

3 = LV? 

4rLV? 

s=o 

LV? 

6=LV? 

7 = LV? 

f^lv? 

9=  C 

LV? 

AArLV? 

A9*LV? 

AC*LV? 

AO»  0 

LV? 

AE=LV? 

af=lv? 

AG*LV? 

AHs  0 

LV? 

AI=LV? 

AJ=LV? 

AK^L V? 

al  = 0 

L V? 

AMsLV? 

A N^LV? 

AO=LV? 

APs  C 

LV? 

AQ»LV? 

AR*LV? 

AS*LV? 

ATS** 

LV? 

AUtLV? 

AV^L V? 

ANsLV? 

AXsp 

LV? 

AYsLV? 

A?rLV? 

AC«LV? 

A1*C 

LV? 

A?sLV? 

A3=LV? 

A4=LV? 

A9  = C 

LV? 

Af *LV? 

A7*LV? 

AAsLV? 

A9*  0 

IV? 

ba^lv? 

B9=LV? 

RCsLV? 

nosc 

L V? 

ne=LV? 

«f*lv? 

RG*LV? 

RHc  0 

LV? 

9I=LV? 

9J=LV? 

RtfrLV? 

9L*C 

LV? 

RM*LV? 

RN*L V^ 

90*LV? 

9P*  0 

LV? 

90=LV? 

RPrlV? 

RSsLV? 

RTsp 

LV? 

PU*LV2 

PV»LV? 

RW*LV? 

RX»C 

LV? 

9Y=LV? 

R7-LV? 

9C=LV? 

«t=  C 

LV? 

GO  TO 
PNO 

9?*LV? 

?SOOl 

R3»LV? 

R4*LV? 

R = * 0 

GIRL  Version 


SUBROUTINE  SEMANT  (N,FAIL ) 

SEMANT 

2 

COMHON/FUNC/  NARY  15 *121 , HARGS • I ARCS ( 5 0)  «F NCLOC ( 5 1 tNFUNC 

CY566 

3 

COMMON/HL/HOL  , AC T ION, F UNC  1 tFUNC2  t FUNC  3 ,L  EFT,  RI  GHT, STRING,  MAXJ 

SFMANT 

4 

COMMON  /TYP/  MARRAV,TYPE1,TYPE2,ERRFLG 

SEMANT 

5 

COMMON  /STRING/  NTVPE , NS TR ,STR 

SEMANT 

6 

COMMON  /JL/  JSTOP 

SEMANT 

7 

COMMON  /GIRL/ N TER MS, PL  US, MINUS, SL ASH,  L PA R, RP AR , COMMA , ST AR, EXP, LT , 

SEMANT 

e 

♦le,gt,ge,eq,ne,or,ano,not,equals,oprano 

SEMANT 

9 

COMMON/NEEOS/ST J, JST ACK, R , JAS , J , JLAST , RT EMP,ST  ACK (NOO) 

SEMANT 

10 

COMMON  /NEED/  ST ART , ASSOC , LE VEL . STOP 

SEMANT 

11 

COMHON/NOPAR/NOPAR,NOEP,NOEPTH, NFL AG 

SEMANT 

12 

INTEGER  HOL,ACTION,FUNC, LEFT , R IGHT , ST R INC, RP AR ,STJ,R, STACK 

SEMANT 

13 

♦ ,EXP,FUNC1,FUNC2*FUNC3,TYPE1,TYPE2,TYPCC5I ,STR  111 ,ST0P 

SEMANT 

14 

$ , ALPHA,BETA,  GAMMA, OPR AND, equals, ANO, OR, COMMA 

SEMANT 

15 

logical  SKIP,FLAG,ERRFLG,FAIL, NOTFLG 

SEMANT 

16 

INTEGER  FUNCRF, ZERO, eiTPUT, PLUS, FL 131 .BITGET 

SEMANT 

17 

INTEGER  GETTYP,GET0IM 

SEMANT 

10 

DATA  FLAG/,FALSE./,FUNCRF/86/»  ZERO/0/ 

SEMANT 

19 

DATA  (TYPE  in • !■ 1 , 51 /4HRE AL, 6HC0MPL X ,6 HO OUBL E, 6HI NTE GR, 6HLOGI CL/ 

SEMANT 

20 

GETTYP  (I  n^MOD  (II  « lOOOOQ  1/10000 

SEMANT 

21 

GE TO IM(III«MOO(II, 1000000) /I  00000 

SEMANT 

22 

EXECUTE 

SEMANT 

23 

FAIL*. false. 

SEMANT 

24 

IFIN  .EQ.  0)  GO  TO  999 

SEMANT 

25 

GO  TO (10, 20 ,3  0 ,40,50,60,70 ,00, 90,1000 ,11  00,120  0,  1300 ,1400,15  00  , 

SEMANT 

26 

S 1600)  ,N 

SEMANT 

27 

10 

R^STj/11  •R/ZIZ 

SEMANT 

28 

11 

FAIL*. TRUE. 

SEMANT 

29 

RETURN 

SEMANT 

30 

PRIHART  RECOGNIZED 

SEMANT 

31 

12 

IFISTJ  .EQ.  PLUS  .OR.  STJ  .EQ.  MINUS)  GO  TO  126 

SEMANT 

32 

IFISTJ  .NE.  RPAR)  GO  TO  121 

SEMANT 

33 

JSTACK*JSTAC<^1 

SEMANT 

34 

STACK! JSTACK)  « SHI  FT  (ST  OP  ,45)  .OR.  SHIFT! J, 15) 

SEMANT 

35 

NTMPsR 

SEMANT 

36 

CALL  SLEVEL(SKIP) 

SEMANT 

37 

JSTACK*JSTACK-1 

SEMANT 

30 

RsNTMP 

SEMANT 

39 

JLAST*1 

SEMANT 

40 

IFUSTOP  .GT,  0)  JLAST«BITGET(STACK(  JSTOP)  ,45,  15) 

SEMANT 

41 

STRING»HOL.JL  AST (-string, STRING  * •TYPEl*  M 

SEMANT 

42 

RETURN 

SEMANT 

43 

121 

CONTINUE 

SFMANT 

44 

GET  TYPE 

SEMANT 

45 

BCTAsGETOIHtSTRI  JM 

SEMANT 

46 

IFCBET*  .NE.  5t  GO  TO  1E5 

SEMANT 

47 

OPEMNO  IS  » FONCTION  REFERENCE 

SEMANT 

48 

IFINOEP  .EO.  01  GO  TO  1» 

SFMANT 

49 

OPRANO  FUNCl-.-l 

SEMANT 

50 

IB 

r<funcrf 

SEMANT 

51 

JST»CK«JST*CF»1 

SEMANT 

52 

ST*CR(  JSTACIO  •SHIFTJR.G5I  .OR.  SH IFT  ( J»1  ,1  5) 

SEMANT 

53 

125 

tLPHt>GETTYPISTRIJI  1 

SEMANT 

54 

IFCTTPEl  .GE.  0>  GO  TO  13 

SEMANT 

55 

SET  TYPE  OF  STATEMENT 

SEMANT 

56 

TYPE1*ALPMA 

SEMANT 

57 

IFINTYPE  .EQ.  3)  TYPE1«-1 

SEMANT 

58 

\ 


G 

lee  string^hol.j(-string, string  ••TypEi**i 

semant 

59 

RETURN 

SFHANT 

60 

1 3 IFfELAG)  GO  TO  15 

SEHANT 

61 

C 

CHECK  FOR  MIXED  MODE  EXPRESSION 

SEHANT 

62 

IFITYPEl  .EQ.  ALPHA  .OR.  ALPHA  .EQ.  51  GO  TO  16 

CY60 

1 

N1*TYPE1^1 

SEMANT 

64 

N2=ALPHA^1 

SEMANT 

65 

ERRFLG*. true. 

SEHANT 

66 

CALL  ERROR<77*TYPEfNl) ,TyPEIN? M 

SEHANT 

67 

G 

STPING^MOL.JC-STRING.STRING  ••TYPE1**I 

SEHANT 

66 

RETURN 

SEHANT 

69 

C 

PARSING  AN  EXPONENT 

SEHANT 

70 

15  IFULPHA  .EQ.  3 .AND.  TYPEl  .EO.  3)  GO  TO  16 

SEMANT 

71 

IF((TYPE1  «EQ.  0 .OR.  TYPEl  .EQ.  21  .ANO.  lALPHA 

•EQ.  0 .OR. 

SEMANT 

72 

S ALPHA  «EQ.  21)  GO  TO  16 

SEHANT 

73 

CALL  ERROR(76»J) 

SEHANT 

74 

errflgs. True. 

SEHANT 

75 

G 

STRING^HOL. Jf-STRING*STRING  '•TYPEl** I 

SEHANT 

76 

RETURN 

SEHANT 

77 

16  IFU.NOT.  FLAG  .AND.  TYPEl  «LT.  ALPHA ) .0  R.  (F  LA  G . 

AND.  ALPHA  .NE.  3 

SEHANT 

76 

♦ .AND.  TYPEl  .LT.  ALPHA))  TYPEl«ALPHA 

SEHANT 

79 

G 

STRING^HOL.Jf- STRING, STRING  ••TYPEl**) 

SEHANT 

60 

RETURN 

SEMANT 

61 

C 

HILL  SCAN  AN  EXPONENT 

SEHANT 

62 

20  IFCSTJ  .lT.  0)  return 

SEHANT 

63 

G 

R»STJ/ll  *R 

SEHANT 

64 

FLAG*. TRUE. 

SEHANT 

65 

RETURN 

SEHANT 

66 

C 

RECOGNIZED  A TERN, PRODUCT  OR  PRIMARY  PERHAPS  NEEDING 

parentmesization 

SEHANT 

67 

30  CONTINUE 

SEHANT 

66 

KTMprR 

SEHANT 

69 

IFINOEP  .EQ.  0)  GO  TO  34 

SEHANT 

90 

G 

OPRANO  FUNCl-.-l 

SEHANT 

91 

34  CONTINUE 

SEHANT 

92 

ITESTsO 

SEHANT 

93 

IFISTJ  .LT.  0)  GO  TO  31 

SEHANT 

94 

G 

R^STJ  *R//32 

SEHANT 

95 

G 

31  R^STOP/39  *R 

SEHANT 

96 

IFISTJ  .LT.  0 .AND.  KTMP  .EQ.  669)  GO  TO  36 

SEHANT 

97 

ITEST«-1 

SEHANT 

96 

32  CONTINUE 

SFHANT 

99 

C 

IF  UNARY  PLUS  OR  MINUS  RETURN 

SEHANT 

100 

lSTCK»eiTGETcSTACKIJSTOP) ♦ 15,1 5) 

SEHANT 

101 

IFfISTCK  .NE«  266  .AND.  ISTCK  .NE.  110)  GO  TO  33 

SEHANT 

102 

JLASTsBITGETlSTACM  JSTOP)  ,45,15)-! 

SEHANT 

103 

IFflSTCK  .EQ.  266)  JL AST * JLA ST -1 

SEHANT 

104 

G 

STRING^HOL.JL  ASTI  -STRING,  STRING  • *TYPE1*  *) 

SEHANT 

105 

G 

STRING^HOL. JC-STRING,STRING  **TYPE1** ) 

SEHANT 

106 

IFIITEST  .LT.  0)  J«J-1 

SEHANT 

107 

RETURN 

SEHANT 

106 

33  CONTINUE 

SEHANT 

109 

IFIITEST  .LT.  0)  J«J-1 

SEHANT 

110 

jstack«jstack»i 

SEHANT 

111 

STACKI JSTACK)  ■SHIFTIST0P,45)  .OR.  SHIFT IJ, 15) 

SEHANT 

112 

NTHP*R 

SFHANT 

113 

CALL  SLEVELISXIP) 

SEHANT 

114 

JSTACK«JSTACK-1 

SFHANT 

115 

1 


R«NTMP 

SENANT 

116 

Jl»SI«l 

SEMANT 

117 

IFUSTOP  .GT.  0>  JL»ST«8ITGETtSTACItUST0Pt  ,i»5. 

15) 

SEHANT 

118 

NTHPstYPEl 

SENANT 

119 

JJ*JIAST 

SEMANT 

120 

IF(BirGEr(STACK(JSTACK>.lf.lG)  .EQ.  A18  .AND. 

XAST  .GT.  1) 

SENANT 

121 

t JJ»JLAST-1 

SEMANT 

122 

STRINGtHOL . JJ*STRING  •TTPEl 

semani 

123 

IFI.NOT.  flag  .or.  NTHP  .EQ.  31  GO  TO  35 

SENANT 

124 

IFdNTHP.EQ.O.OR.NTnP.EO.ei.ANO.tTTPEl.EQ.O.OR 

. TTPEl. EQ.2))GOTO 

35 

SENANT 

125 

ERRFLG*. TRUE. 

SEHANT 

126 

CALL  ERRORirS.Jl 

SENANT 

127 

35  CONTINUE 

SEMANT 

128 

IFITTPEl  .GT.  2 .OR.  NTrPE  .GT.  11  CO  TO  38 

SENANT 

129 

FUNC«FUNC1 

SENANT 

130 

IFITTPEl  .EQ.  1)  FUNC*FUNC? 

SENANT 

131 

IFITTPEl  .EQ.  2)  FUNC«FUNC3 

SEHANT 

132 

STRINGthOL.JLAST  LEFTI.l  LPAR..1  FUNCl 

SEHANT 

133 

strincthol.j  right  RPAP 

SENANT 

134 

38  IFIITEST  .LT.  0 .AND.  STJ  .LT.  81  J*J»1 

SEMANT 

135 

FLAG*. FALSE. 

SENANT 

136 

RETURN 

SENANT 

137 

39  flag*. FALSE. 

SENANT 

138 

GO  TO  11 

SEMANT 

139 

CHECH  FOR  CORRECTNESS  OF  SUBSCRIPTS  AND  00  INPLIEO  LIST  PARAMETERS 

SENANT 

140 

NRsff 

SENANT 

141 

^♦STj/11 

SENANT 

142 

N6tTA«GeT0IH(STR< Jll 

SENANT 

143 

irCNff  .EQ*  359  .AND.  NBETA  .NE.  •»»  GO  TO  47 

SENANT 

144 

AL  PMA«GETTYP<STRt  JU 

SEMANT 

145 

GAHHAs^TRt JI/1000000 

SENANT 

146 

IfiHJfPE  .€Q.  3>  OO  TO  45 

SENANT 

147 

IFINR  .EQ*  839  .AND*  NBETA  .EQ.  0)  GO  TO  45 

SEMANT 

148 

IF  (NR  .EQ*  359)  GO  TO  45 

SENANT 

149 

IFINR  .EQ*  Z\  .AND.  NBETA  .EQ*  4)  GO  TO  45 

SENANT 

150 

TFCNBETA  *EQ*  0 *ANO*  NR  .EQ.  935)  GO  TO  45 

SENANT 

151 

IFINTyPE  *E0*  2 .and#  NR  .EQ.  935  .ANO.  STRIJ- 

1)  .NE.  -7)  CO  TO 

1.5 

SENANT 

152 

tFINTVPE  .EQ.  2 .ANO*  NR  .EQ.  359  .ANO.  NBETA 

.EO.  01  GO  TO  11 

SENANT 

153 

CALL  ERR0R(79«J) 

SENANT 

154 

ERRFLG*.TRUE. 

SENANT 

155 

45  CONTINUE 

SENANT 

156 

IFCGAHHA  *GE*  6 .ANO.  NBETA  .EQ.  4)  CALL  ERROR  (76) 

SENANT 

157 

IFIALPHA  *E0.  3)  GO  TO  46 

SEMANT 

158 

N1«ALPHA»1 

SENANT 

159 

ERRFLG*. TRUE. 

SENANT 

160 

CALL  ERROR (80 « TYPE (Nl) ,J) 

SENANT 

161 

46  IFINBETA  *EQ.  4)  RETURN 

SENANT 

162 

HARGS*MARGS«1 

SENANT 

163 

0PRAN0IFUNC2  ■ ‘MARCS' • .FUNC3  “J". LEVEL  “N0FPTH“I 

SENANT 

164 

rVR»  (HARCS»?)  /3 

Sf  HANT 

165 

IFdVR  .GT.  501  GO  TO  1610 

CY58B 

5 

ICOL*?0*HOO(HARGS-1,  3)  ♦lO 

SENANT 

166 

IVAL*NOO (STR(J), lOOOOl 

Sf  NANT 

167 

lARGSl  tVR)  >Bir  PUT  (lARGSI  I VR)  * I V A L « I COL  ) 

SENANT 

166 

IF (NR  ,EQ.  839)  GO  TO  49 

SE  NANT 

169 

IFINTYPE  .NE.  3)  RETURN 

SENANT 

170 

FLAG  SUBSCRIPT  IN  I/O  LIST 

Sf  NANT 

171 

URGS  CtVRI*BI  TPUT  (lARGSC  IVRI  »lt  ICOL^SI 

SEMANT 

17? 

RETURN 

SFHANT 

173 

c 

FLAG  00  INOFK  IN  I/O  LIST 

SEHANT 

174 

4 9 lARGSf IVR>«BITPUT  CIARGSl IVR) ICOL^SI 

sfmant 

175 

IFINFLAG  .LT.  1)  RETURN 

SEHANT 

176 

IARGS(IVR>*BITPUT (lARGSC IVRI ,FL(NFLAG) tlCOL^lQ ) 

SEHANT 

177 

RE  TURN 

SEHANT 

178 

47  NRsR 

SFHANT 

179 

c 

SUBSCRIPT  DOES  NOT  BEGIN  MITH  CONSTANT*  FORCE  SEARCH  FOR  VARIABLE 

SEHANT 

160 

GO  TO  11 

SEHANT 

161 

c 

CHECK  FOR  PROPER  NUH6ER  OF  SUBSCRIPTS 

SEHANT 

16? 

50  IF(  BETA  «EQ.  4 .OR*  R • NE . 45?)  GO  TO  5? 

SEHANT 

163 

HARGS«MARGS^1 

SEHANT 

164 

G 

OPRANOCFUNC?  • * HA  RGS*  • ,FUNC3  * • J- 1 * • , LEV  EL  ••NOfPTH'M 

SEHANT 

165 

IVRs(HARGS»?)  /3 

SEHANT 

166 

IFdVR  «GT*  50)  GO  TO  1610 

CY5  6B 

6 

ICOL«?0*HOOCHARGS-lt3)^lO 

SFHANT 

167 

IVAL^HOO  (STRU-1),  10000) 

SEHANT 

166 

IARGSaVR)«6ITPUT  ( lARGSC  IVR)  «IVALtICOD 

SEHANT 

169 

IFINOPAR  *LE.  0)  GO  TO  5? 

SEHANT 

190 

G 

OPRANQfACTION. -1/5?  •MFUNC 

SEHANT 

191 

lARGS  <IVR)«BITPUT  dARGSC  IVR)  *HFUNC  «TCOL  «3) 

SEHANT 

19? 

IARGS(IVR)=BITPUT  dARGSI  IVR)  ,NARGS*  ICOL^  9) 

SEHANT 

193 

C 

IF  NO  STRING  LEFT,  RETURN  IF  CONST  4 NT , VAR  I AB LE  OR  I/O  LIST 

SEMANT 

194 

5?  IFCSTJ  .LT.  0 .AND.  CBETA  .EQ«  0 .OR.  BETA  .EQ.  4 

SEHANT 

195 

S .OR.  NTVPE  .EQ,  3))  RETURN 

SFHANT 

196 

IFIBETA  .GT«  NARRAY)  GO  TO  55 

SEHANT 

197 

errflg=.true, 

SEHANT 

196 

CALL  ERR0R(61,J) 

SFMANT 

199 

55  IF<R  .EO.  45?)  NARRAY=0 

SEMANT 

?00 

IF(R  •EO.  316)  NARRAY«1 

SEHANT 

?01 

IFfR  .EQ.  60)  NARRAYs? 

SEMANT 

?Q? 

IF(R  .EQ*  103)  NARRAY»3 

SEHANT 

?03 

IF<STJ  .LT.  0)  GO  TO  56 

SEHANT 

?04 

G 

R^STJ  *R//56 

SEHANT 

?05 

56  IFCNTYPE  .EQ.  3 .AND*  NARRAY  .EQ.  0)  GO  TO  57 

SEMANT 

206 

IFtBETA  .GE*  1 .ANO*  BETA  .LE«  3 .ANO.  NOPAR  . EQ.  01 

SEHANT 

207 

• CALL  ERRORC62.J) 

SEHANT 

206 

57  NARRAY=-1 

SEHANT 

209 

GO  TO  11 

SEHANT 

^^0 

56  IFCNTYPE  .CO.  3 •ANO*  NARRAY  .EO.  0)  RETURN 

SEMANT 

211 

IFISTJ  .EQ.  RPAR  .ANO.  NARRAY  .LT.  BETA  .ANO.  J .EO.  HAXJ) 

SEMANT 

21? 

S CALL  ERROR(6?,J) 

SEHANT 

213 

IFCSTJ  .EQ.  RPAR)  NARRAY«*1 

SEHANT 

214 

RETURN 

SEHANT 

215 

C 

reset  TYPE  OF  STATEHENT  IN  ANTICIPATION  OF  SEARCH  FOR  BOOLEAN  PRIMARY 

SEHANT 

216 

60  CONTINUE 

SEHANT 

217 

NOTFLG*. FALSE. 

SEHANT 

216 

IFCSTRCJ-IJ  .EQ.  -17)  NOTFLC*. TRUE. 

SEHANT 

219 

TYPE1«-1 

SEHANT 

220 

G 

STRING^HOL.JC- STRING, STRING  ••TYPEl** ) 

SEHANT 

221 

IFCSTJ  .NE.  OPRANO)  GO  TO  65 

SEHANT 

222 

ALPHAsGETTYPCSTrc J)) 

SEHANT 

223 

RETA«GET0IMCSTRCJ)) 

SEHANT 

224 

IFCALPHA  .NE.  41  GO  TO  11 

SEHANT 

225 

65  CONTINUE 

SEHANT 

226 

G 

R»STJ/11  »R 

SEHANT 

227 

I ’.H 

Ih. 


O o 


RETURN 

SEMANT 

2?e 

c 

tF  eOOLFAN  PRINARV  IS  AN  ARCTHHFTIC  COMPARE  CONTINUE  PARSING  PRIMARY 

SEMANT 

229 

70  IFCSTJ  *LT*  0)  RFTURN 

ScMANT 

230 

IFITYPEI  .EQ.  CO  TO  75 

SEMANT 

231 

G 

R^STJ  'R/ll 

SEMANT 

232 

C 

RELATIONAL  OPERATOR  FOUND 

SEMANT 

233 

IFINOEP  .EQ.  01  RETURN 

SEMANT 

239 

G 

OPRANO  FUNCl-.-l 

SEMANT 

235 

RETURN 

SEMANT 

236 

C 

IF  BOOLEAN  VARIABLE  OR  CONSTANT,  SET  STATE  TO  STOP 

SEMANT 

237 

75  RsSTOP 

SEMANT 

230 

JSTACK*JSTACF^1 

SEMANT 

239 

STACKS JSTACKI  sSHIFT  CR,%5)  .OR.  SHIFT  f J,l 5) 

SEMANT 

290 

GO  TO  11 

SEMANT 

291 

c 

COMPARE  types  on  BOTH  SIDES  OF  RELATIONAL  EXPRESSION 

SEMANT 

292 

00  IFCTYPEl  «EQ.  0 .OR.  TYPEl  .EQ.  2 .OR.  TYPEl  .EQ.  31  GO  TO  05 

SEMANT 

293 

ERRFL6=. TRUE. 

SEMANT 

299 

CALL  ERROR(03,J) 

SEMANT 

295 

TYPE1»-1 

SEMANT 

296 

G 

STRING ♦HOL.JC-STR I NG.STRING  • 'TYPEl* • 1 

SEMANT 

297 

05  TYPE?«TYPE1 

SEMANT 

290 

GO  TO  11 

SEMANT 

299 

C 

BOOLEAN  PRIMARY  RECOGNI 7EO-SET  TYPE  TO  BOOLEAN  AND  CONTINUE  PARSE 

SEMANT 

250 

50  IFITYPEI  .EQ.  TYPE2  .OR.  TYPEl^TYPE?  .EQ.  2 .OR. 

SEMANT 

251 

♦ TYPE?  .Lit  OJ  GO  TO  95 

SEMANT 

252 

NlsTYPEl^l 

SEMANT 

253 

N?sTYPE?^l 

SEMANT 

259 

CALL  ERR0R<77,TYPE(N1I,TYPE(N?U 

SEMANT 

255 

errflg«.true. 

SEMANT 

256 

95  TYPE1*4 

SEMANT 

257 

TYPE?«-l 

SEMANT 

250 

IFCSTJ  .LT.  0)  return 

SEMANT 

259 

G 

STRING 'HOL-J I -STRING, STRING  **TYPEl**) 

SEMANT 

260 

GO  TO  11 

SEMANT 

261 

C 

PARSE  REACHED  BLIND  ALLEY-MUST  BACK  UP  AND  REMOVE  PARENTHESES  CREATED 

SEMANT 

26? 

999  JM=BITGET<STACKIJSTACKI ,95,15 > 

SEMANT 

263 

K«  JH 

SEMANT 

269 

00  996  KK*JM,J 

SEMANT 

265 

G 

STRING^HOL.K/ 995 ♦STRING. 1/996  'TYPEl 

SEMANT 

266 

GO  TO  995 

SEMANT 

267 

996  K«K-1 

SEMANT 

260 

995  CONTINUE 

SEMANT 

269 

DO  990  I«JM,J 

SEMANT 

270 

G 

STRING^HOL.I(-LEFT,-RIGHT ) 

SEMANT 

271 

990  CONTINUE 

SEMANT 

272 

G 

900  OPRANO^FUNC3.-1  *JN 

SEMANT 

273 

IFfJN  .LT.  JM)  GO  TO  905 

SEMANT 

279 

G 

OPRANO C^FUNC?-.-! , ♦FUNC3 - . -1 , ♦! EVEL - ♦ - 1» 

SEMANT 

275 

GO  TO  900 

SEMANT 

276 

G 

905  OPRANO^FUNC?. -1  *MARGS 

SEMANT 

277 

G 

OPRANO^LEVEL.-l  'NOEPTH 

SEMANT 

2/0 

RETURN 

SEMANT 

SEMANT 

279 

200 

C 

RECOGNIZED  FUHC T lON-PREPARE  TO  SET  TYPE  OF  ARGUMENTS  FOR  THE  'NOEPTH 

SEMANT 

201 

c 

FUNCTION  IN  THIS  STMT 

SEMANT 

202 

1000  CONTINUE 

SEMANT 

203 

NOfPTH»NOEPTH»l 

SEMANT 

209 

I .'I 


N0FP*N0EP«>1 

SEMANT 

?05 

NAPGS^O 

SEMANT 

?86 

G P»STJ/ll 

SEMANT 

387 

NARGS«1 

SEMANT 

380 

G OPPANOIOPRANO  ' • T TPE 1 • • • ST RI NG • ♦ NARGS • • , ACT  I ON  •'NOEPTM 

• • ) 

SEMANT 

389 

G OPRANO  FUNCl  * *0 • • 

SEMANT 

390 

typei«-i 

SEMANT 

391 

NOPARsNOPAR^i 

SEMANT 

393 

RETURN 

SEMANT 

393 

SEMANT 

394 

C KEEP  TRACK  OE  THE  NUHBER  AND  TYPES  OE  ARGUMENTS  IN  EUNCTION 

CALLS 

SEMANT 

395 

C HUST  USE  STACK  FOR  POSSIBLE  RECURSIVE  FUNCTION  USE 

SEMANT 

396 

1103  CONTINUE 

SEMANT 

397 

G R^STJ/ll  *R 

SEMANT 

398 

G OPPANO<»STRINCr-1/1103  • NARGSt  ♦STRING- 1, »ACT ION, -1  • 

MFUNC) 

SEMANT 

399 

G OPRANO^FUNCl. -1  'lEXP 

SEMANT 

300 

110  3 continue 

SEMANT 

SOI 

C STORE  ARGUMENT  TYPES 

SEMANT 

303 

IFCNOEPTH  ,GT,  5)  CALL  ERROR  (85) 

SEMANT 

303 

IF!  NOE  PTH  .GT,  5)  GO  TO  1130 

SEMANT 

304 

IFINARGS  *LE.  63)  GO  TO  1104 

SEMANT 

305 

errflc*.true. 

SEMANT 

306 

call  ERR0R(S4«  NOEPTH) 

SEMANT 

307 

GO  TO  11 

SEMANT 

308 

1104  CONTINUE 

SEMANT 

309 

MM«I11^NARGS) /6 

SEMANT 

310 

ITENP^NARC$-G* (MH-^) 

SEMANT 

311 

ICOL*9*ITEHP-6 

SEMANT 

313 

NARY (HFUNCtHM) *BITPUT(NARY (NFUNCtMMI * MOO  U TYPE !♦ 1 ) 1 6 ) » 

ICOLt 

CY60 

3 

IF(STR(J-?)  «NE.  -6  .AND*  STR(J-E)  .HE.  CO  TO  1130 

SEMANT 

314 

NOIHsGETOIM(STRU-l)) 

SEMANT 

315 

IFINOIH  .GE.  4)  GO  TO  1130 

SEMANT 

316 

C STORE  DIMENSIONALITY  OF  ARGUMENTS 

SEMANT 

317 

NARYIMFUNC  «HM)«BITPUT (NARYTMFUNC  ^MM ) ,N Ql M, IC OL ♦S ) 

SEMANT 

318 

1130  CONTINUE 

SEMANT 

319 

NARYfMFUNC  t HM ) « B ITPUT ( NAR Y( MF UNC  f MM ) , X EKP, 54 ♦! TEMP) 

SEMANT 

330 

IFfSTJ  .EQ.  COMMA)  GO  TO  1105 

SEMANT 

331 

NARYIMFUNCf 1) >NARGS 

SEMANT 

333 

G OPPANOI^ACTION-.-1, ♦OPRANO. -1/1135  ‘TYPED 

SEMANT 

333 

G OPRANO (♦FUNCl  - .-1 •♦OPRANO-.-l) 

SEMANT 

334 

1135  NOPAR«NOPAR-l 

SEMANT 

335 

NOEP«MOEP-l 

SEMANT 

336 

RETURN 

SEMANT 

337 

1105  TYPE1«-1 

SEMANT 

338 

G STRINC^HOL.Jf -STRING* string  • ‘TYPEI** • 

SEMANT 

339 

NARGS«NARGS  ♦! 

SEMANT 

330 

G OPRANO  STRING  **NARGS“ 

SEMANT 

331 

G OPRANO  FUNCl-. -1  “O** 

SEMANT 

333 

RETURN 

SEMANT 

333 

C SAVE  TYPE  OF  STAEMENT  WHILE  PARSING  EXPONENT 

SEMANT 

334 

130  0 CONTINUE 

SEMANT 

335 

G STRlNG^HOL.Jf  - STRING. STRING  “TYPEl**) 

SEMANT 

336 

TYPEI--1 

SEMANT 

337 

G R^STJ/ll  ‘R 

SEMANT 

338 

RE  TURN 

SEMANT 

339 

1 30  0 CONTINUE 

SEMANT 

340 

IF  (ST J .LT.  01  RETURN 

SEMANT 

341 

I )(t 


IFfSTJ  .NE*  AND  .AND*  STJ  .NC*  OR  .ANO*  STJ  .HE*  NOT  I GO  TO  11  SEHAHT 

G R^STJ/11  *R  SFHANT 

iFfNOEP  .€Q.  01  RETURN  SEHANT 

C LOGICAL  OPERATOR  FOUND  SfHANT 

G OPRANO  FUNCl-.^l  SFHANT 

return  SFHANT 

GILOO  R^STj/11  »R  SFHANT 

C LEFT  PAREN  FOUND  IN  I/O  LIST  SFHANT 

NFLA6sNFLAG«1  SFHANT 

FL  INFLAG)«HARGS  SFHANT 

RETURN  SFHANT 

G1500  R^STj/11  *R  SFHANT 

IF(STJ  ,EQ.  COHHAI  RETURN  SFHANT 

C RIGHT  PAREN  FOUND  IN  I/O  LIST  SFHANT 

NFLAG*NFLAG-1  SFHANT 

RETURN  SFHANT 

1600  CONTINUE  SFHANT 

TYPE1*L  SFHANT 

return  cysob 

1610  CALL  ERR0R(95I  CYS6B 

STOP  CY588 

G COHPLETE  SEHANT 


subroutinc  scpar 

SFPAR 

2 

COMMON  M1326)  ,0  (500  I.  lOTBL  <9*500  )• 

INITI0m,LASTIO(]l,  ISRCHC3  1, 

RICH 

2 

JPTP,N,N,JTrP,LST«PT,N?,irNCNH,LOCIO,NXTID,  lOTTP.NIO.  LOC  t 

CY50A 

00 

2 

L TTP, ITTP, IBL HOT, NODE, lEPP.IOES 

RICH 

4 

COHHON/FORHAT/  lOESST.IOESNO.  IGPSr  .IGPND.  ICRP  ,S  EPST  .SEPNOt 

CV56A 

4 

1 

OIR,ICOM«ISEP 

SEPAR 

5 

iNTecep  Atscpsr, sepno, oir,blan<« slash, comma 

SFPAR 

6 

DATA  BLANK/IH  /, SLASH/ IH // ,C OMMA/IH 

./ 

SFPAR 

7 

C**  Th 

IS  ROUTINE  CHECKS  The  SYNTAX  OF  FIELD  SEPARATORS  AND  RETURNS 

SEPAR 

a 

C** 

ISEP-1  - VALID 

SEPAR 

9 

ISEP»0  - non-separatop 

SFPAR 

10 

C** 

ISEP«-l  - INVALID 

«5FPAR 

tl 

ICOM^O 

SFPAR 

12 

ISLASH«0 

SEPAR 

13 

00  20  Isl,N 

SFPAR 

14 

JJ«SEPST  ♦OIR*  < i-n 

SFPAR 

15 

IF(A(JJ»  •EQ.  BLANK)  GO  TO  20 

SFPAR 

16 

IMAfJJ)  ,£0.  SLASH)  GO  TO  5 

SEPAR 

17 

IF(AIJJ)  ,EQ.  COMMA)  GO  TO  10 

SFPAR 

16 

GO  TO  30 

SFPAR 

19 

5 

CONTINUE 

SFPAR 

20 

ISLASH«1 

SFPAR 

21 

IF  eiCOM  ,£0,  1 ) GO  TO  40 

SEPAR 

22 

GO  TO  20 

SFPAR 

23 

IQ 

IFfISLASH  .EQ,  1 .OR.  ICON  .EQ.  1) 

GO  To  AO 

SFPAR 

24 

ICOHsl 

SFPAR 

25 

20 

CONTINUE 

SFPAR 

26 

GO  TO  40 

SFPAR 

27 

30 

IFdSLASH  .EQ,  0 .and.  ICON  .EO.  0) 

GO  TO  35 

SEPAR 

20 

ISfP*l 

SFPAR 

29 

SEPNOs JJ-OIR 

SFPAR 

30 

RETURN 

SFPAR 

31 

35 

CONTINUE 

SFPAR 

32 

ISEP*0 

SFPAR 

33 

SEPNO* JJ 

SFPAR 

34 

RETURN 

SFPAR 

35 

40 

ISEP=-1 

SFPAR 

36 

RE  TURN 

SFPAR 

37 

END 

SEPAR 

30 

SUBROUTINE  SI  HP 

SIM  F 

2 

COHNON  A (13361  ,0 (500 l,IOTBL<S«SOO)tINITlO(3) .L  ASTI 0 ( 3 1 , ISRCH ( 3 1 • 

RICH 

2 

• JPTR,NtN,jTTP,LSTARTtN3, IfNCN H, L06I0 , NK TIO t 10 TYP, NIO , LOG • 

CY5  8A 

SO 

2 LTYP, ITYP,IBLKOT*HOOEf lERR* lOES 

RICH 

4 

CONNON/BASBLK/I6LOCK(2500» ,NBLOCK*NB*NBRNCH 

CY56A 

6 

01  HENS  ION  IALPH1(7I«IALPH2(B)  •IALPH3(5),  IALPH6  (10  1 

SIMP 

5 

DATA  (IAlPHl(n,I*l*7»/lHR*lHE,lHT*lHU,lHR.lHN*lH  /, 

SIM  F 

6 

1 (lALPH?(I)»I>l«9l/lHC*lH0«lHN,lHr«lHI«lWtlHU»lHE»lH 

SIMP 

7 

2 (IALPH3(II«I<lf5l/lHS,lHTflHO,lHP«lH  / 

SIMP 

S 

3 « (IALPH4(IM«ltlO)/lHB«lHL«lHO«lHCf  1HK,1H0«1HA,1HT,1HA«1H  / 

SIMP 

9 

C**  THIS  ROUTINE  PROCESSES  RE  TURN,  CONT I NUE  # STO  P,  ANO  BLOCK  DATA 

SIMP 

10 

lEdTYP  .EQ.  101  GO  TO  25 

SIMP 

11 

IFdTYP  ,EQ.  n GOTO  15 

SIMF 

12 

IFdTYP  .EQ.  291  GO  TO  35 

SIM  F 

13 

C**  CHECK  RETURN  STATEHENT  ANO  STORE  BRANCH  IN  BASIC  BLOCK  TABLE 

SIMP 

14 

00  10  1*1,7 

SIMP 

15 

IF(NEXT(JPTR)  .NE.  lALPHldl)  GO  TO  50 

SIMP 

16 

10  CONTINUE 

SIMP 

17 

NB*1 

SIMF 

IS 

NBRNCH*! 

SIMP 

19 

NBLOCK*NBLOCK»l 

SIMF 

20 

IBLOCK(N0LOCKI*999 

SIMP 

21 

RETURN 

SIMF 

22 

C**’  CHECK  CONTINUE  STATEHENT 

SIMP 

23 

l9  00  20  1*1,9 

SIMF 

24 

IF(NEXT(JPTRI  .NE.  IALPH2dtl  GO  TO  50 

SIMF 

25 

20  CONTINUE 

SIMP 

26 

RETURN 

SIMP 

27 

C**  CHECK  STOP  STATEMENT  AND  STORE  BRANCH  IN  BASIC  BLOCK  TABLE 

SIMP 

20 

25  00  30  1*1,5 

SIMP 

29 

1FCNEXT(JPTRI  .NE.  IALPH3(in  GO  TO  $0 

SIM  F 

30 

30  CONTINUE 

SIMP 

31 

N6*l 

SIMF 

32 

NBRNCH«1 

SIMP 

33 

NBLOCK*NBLOCK*l 

SIMP 

34 

IOLOCK(NBLOCK>  *999 

SIMP 

35 

RETURN 

SIMF 

36 

C**  CHECK  BLOCK  DATA  STATEHENT 

SIMF 

37 

35  00  40  1*1,10 

SIM  F 

38 

IF(NEXT(JPTR)  .NE.  IALPH4(in  GO  TO  50 

SIM  F 

39 

40  CONTINUE 

STM  F 

40 

return 

SIM  F 

41 

50  CALL  ERR0R(7I 

SIMP 

42 

RETURN 

SIMF 

43 

END 

SIMF 

44 

FORTRAN  Version 


subroutine  SLEVEKFflIU 

COHHON/L VARGS/LVrUNC,LVVftRG*  LVVAOfLVVPO$ ♦LVVTYP,  LVVAL  * 

♦ LVHEAOaVVNVLtLVOEST.LVVALSdO)  ,tVTYPf  (1  01  ,LVS«TP 
COHMON/LVTA0L/LVTSIZ,LVHAP|  1»/LVVSE0/LVSIZE*LVS0SPI  II 

common  /need/  ST  art, assoc t level .stop 

COmmON/NEEOS/STJ,  JSTACK.R,  JAS,  J,  JLASr.RTfKP.ST  ACK(<»0  0) 
common  /string/  NNN<Z),STR 
COMMON  /JL/  JSTOP 

INTEGER  START, ST0P,ASS0C,STAC<,STRI1),ST J.P.PT EM P 
INTEGER  BITGET 

logical  fail 

GO  TO  25000 
2500  1 continue 
RTFMPsO 
JSTOP=JSTACK 

10  IFUSTOP  ,EQ.  0)  GO  TO  40 

NPNTp=PITGET! STACKIJSTOPI ,60 ,15) 

IF(NPNTR  ,GT,  0 .AND,  NPNTR  ,LT,  7777701  GO  TO  20 
IF(0rTGET($TACK(JSTOP| ,T0,15I  .NE.  01  GO  TO  30 
JSTOP* JSTOP-l 
GO  TO  10 

20  JST0P*NPNTR-1 
GO  TO  10 

30  STACK( JSTACKI  * STACK! JSTACKI  .AND.  7 77 7 77 77 7 7 77  77 7 0 0 0 0 0 B 
STACK  US  TACKI  = ST  ACK  IjST  A C K>  .OR,  JSTOP 
JAS*PI T GET (STACK  (JSTOP) , 30,15) 

R=BITGET(STA:k  (JSTOP)  ,15, 15) 

PTFMPsP 


LVVPOS  = JAS 

LVVTYP  = 3 

LVFUNC*  LEVEL 

LVVAPG*  R 


S 

40 
2500  0 


CALL  LVFIN0(LV2  A,LV2 

LVl  AAO  « R 

IF  (LVVAL. NE, -1)  LVl  AAO 
R * LVl  AAO 
FA IL=. false. 

IF (BIT  GET (STACK (JSTOP) ,6  0,15 
STACK (JSTOP)  =STACK(JSTOPI  , 
RE  turn 
FAIL*. true. 

RE  turn 
RE  TURN 
CONTINUE 

LV?  A*LV2  0*LV2 

GO  TO  25001 

ENO 


e,LV2  C.LV2  ni 

= LVVAL 


I .EQ.  77777B) 

AND,  77777777777777700000R 


C*LV2  0*0 


SL^'VEL  2 


SLEVEL  3 
SLPVEL  4 
SLf’VEL  5 
SLEVEL  6 
SLEVEL  7 
SLEVEL  8 
SLEVEL  9 


SLEVELll 
SLEVEL12 
SLEVEL13 
SLEVEL14 
SL*"VEL15 
SL^VELIG 
SLEVEL17 
SLEVEL18 
SLEVEL19 
SLEVEL2C 
SLEVEL21 
SLEVEL22 
SLEVEL23 
SLEVEL24 
SLFV  EL25 


SL 

f V 

EL 

27 

SL 

EV 

EL 

28 

SL 

EV 

EL 

29 

SL 

FV 

EL 

30 

SL 

EV 

EL 

31 

SL 

EV 

EL 

32 

GIRL  Version 


SUBROUTINC  SLEVELCrAIL) 

SLEVEL 

2 

COMMON  /need/  start, ASSOCtLE VEL. stop 

SLE VEL 

3 

COMMON/NEEOS/STJ, JSTACK,R, JAS, J,JLAST,RTEMP, STACK (40  0 I 

slevel 

4 

COMMON  /STRING/  NNM(2I,STR 

SLEVEL 

5 

COMMON  /JL/  JSTtDP 

SLEVEL 

6 

INTEGER  START, STOP, ASSOC , STACK , STR ( U , ST J,R, RTEMP 

SLE  VEL 

7 

INTEGER  BITGET 

SLEVEL 

A 

LOGiCAt  FAIL 

SLEVEL 

9 

EXECUTE 

SLEVEL 

10 

RTEMPsO 

SLE  VEL 

11 

JSTOP« JSTACK 

SLEVEL 

12 

10  IMJSTOP  .EO.  0>  GO  TO  40 

SLEVEL 

13 

NPNTR*BITGET(STACK(JST0P» ,60, 15) 

SLEVEL 

14 

IF(NPNTR  .GT.  S .ANO.  NPNTR  .LT,  T77T7B)  GO  TO  20 

SLEVEL 

15 

IE (0ITGE TiSTACKIJSTOP) *30, 15)  .NE.  0)  GO  TO  30 

SLEVEL 

16 

JSTOP=JSTOP-l 

SLEVEL 

17 

GO  TO  10 

SLEVEL 

lA 

20  jstop=npntr-i 

SLEVEL 

19 

GO  TO  10 

SLEVEL 

20 

30  STACK( JSTACK) sSTACK(JSTACK)  .ANP,  777777777777777000000 

SLEVEL 

21 

ST  ACK( JS TACK) -STACK (JST A CIO  .OR.  JSTOP 

SLEVEL 

22 

JAS»8ITGET (STACK  ( JSTOP ) * 30 * 1 5 ) 

SLEVEL 

23 

R= BITGET (STACK (JSTOP) « 15,15) 

SLE  VEL 

24 

RTEMP-R 

SLEVEL 

25 

R^LEVEL.JAS  *R 

SLEVEL 

26 

FAIL*,FALSE. 

SLEVEL 

27 

IF  (BITGET(STACKUSTOP)  *60,15)  ,EQ.  77777  0) 

SLEVEL 

2A 

S STACKfJSTOP)*STACK( JSTOP)  .ANO.  77 77 777 7777 77 77 0 0 00 0 B 

SLEVEL 

29 

RETURN 

SLEVEL 

50 

40  FAIL-. TRUE. 

SLEVEL 

31 

RETURN 

SLEVEL 

32 

complete 

SLEVEL 

33 

SUBPOUTINE  SOJEEZ 

SQUEEZE 

2 

COHHON  a C13?6I  ,0  <S00) » IOTBU  8,S00) , INITIOI3I  ,L  ftSTIO<  3)  ,ISPCH(3  » ♦ 

RICH 

2 

• JPTR,N,M, JTTP,LSTAPT,N?, IFNCNM,lOGIO,NXTID, IOTYP,NlO,LOCt 

CY58A 

80 

? ltyp,  jtyp, <ot ,mooe ♦iepr,  ioes 

RIC  ► 

4 

INTEGER  A,0.9LANK,AICH 

SQUEEZE 

4 

DATA  BLANK/IH  /♦AICH/IHH/ 

SQUEEZE 

5 

c**  the  purpose  of  this  routine  is  to  squeeze  The  blanks  out  of  a 

SQUEEZE 

6 

c**  character  string  ~o“  which  constitutes  a language  element 

SQUEEZE 

7 

J=C 

SQUEEZE 

8 

DO  10  I s 1 • M 

SQUEEZE 

9 

IFJOin  .EQ.  blan*o  go  to  10 

SQUEEZE 

10 

jsj^l 

SQUEEZE 

11 

0(  J)=0(I) 

SQUEEZE 

12 

IFIOIJ)  .NE.  AICH)  GO  to  10 

SQUEEZE 

13 

IFtjTYP  ,NE.  3>  GO  TO  10 

SQUEEZE 

14 

C**  IF  character  string  constitutes  a HOLLERITH  CONSTANT,  RETURN 

SQUEEZE 

IS 

M^Mf  J-I 

SQUEEZE 

16 

RE  TURN 

SQUEEZE 

IZ 

10  CONTINUE 

SQUEEZE 

18 

M=  J 

SQUEEZE 

19 

C**  SET  -M“  = SIZE  OF  STRING 

SQUEEZE 

20 

return 

SQUEEZE 

21 

ENO 

SQUEEZE 

22 

! 1(1 


FORTRAN  Version 


'^U'^POUTINf  SSTOPtFaiL* 

COHMON/L  VfiPGS/  LVrUNC.L  VVaPG,LVVftOtLVVPOS,LVVTYP,  LVV4L* 

♦ L AT  ,C  «/VN(/L  .LVOeST,LVVflL‘;(n»,U/TrPf(lCJ*LV$>fIP 
CCMMON/LVTfl0L/LVTSI7,LVHaP(  1 ) /L VV S fQ /L VS  1 7 F, L VSOS P ( 1» 

rO^MON  /NEED/  ST  APT, assoc, LEVEL .STOP 

CO»-MON/^JEEOS/ST  J,  JSTACY,P,  JAS,  J,  JLaST  ,PT  EMP,  ST  aCK  140  0 ) 
rOMMON  /STpING/  NNN<2),STP 

INTEGEP  STaPT,  STOP, assoc ,STaC<,STP(l » , ST  J, P, TE  HP 
INTEGEP  PITG^’T  ,BITPUT 

logical  fail 

GO  TO  ?*^0C0 
?5  30  1 rONTINl'E 

JST0PS= JSTaCK 
5 CONTINtj" 

LWTvP  = 1 
LWPOS  = 1 
LVINOV  = 0 
LVFUNC=  ASSOC 

LVVAPG=  P 

CALL  LVFINOd  VTNOX,l  V I NO  X , L V I NOX  , L V I N HV) 

Lvi  aan  = p 

IF  UVVAL.NE.-1*  LVI  AAO  = LVVAL 
LVVTP  = LVVAl 
LVVAL  = -IOC 

IF  (L  VVTP.FQ. - 1 1 go  to  10 

JSTOPSr JSTOP^ ♦ I 

ISTCKsPTTGET(STaCK(JST0PS»,4F,ic) 

ST  ac<  USTOPS)  =SMTFT  ( ISTC<  » 15  » .CP.  SHIFT  (P,  45) 

10  rCNTINtiE 

LVI  AAO  = P 

LVVAL  = -ICO 

IF  (LVI  aao.Nf,  STOP)  LVVAl  = -i 

LVVTP  = LVva. 

LVVAL  = -IOC 

IF  (LVVTp.nE.-1)  GO  TO  ?0 

LVVTYP  = 3 

LWPOS  = 1 

LVINDX  = 0 

LVFUNC=  STOP 

LVVAPG=  LVI  AAO 

call  LVFINO(LVlNnx,LVlNOX.LVINOX,LVlNOX) 

LVI  AAI  = LV1  AAP 

IF  (LVVAL. NE.-l)  LVI  AAI  = LVVAL 
LVVTC  = LVVAl 
LVVAL  - -100 

IF  (LVVTP, FO.  -1)  GO  TO  3C 

P = L VI  AA  r 

LVVTC  s LVVAl 
LVVAl  ? -100 

IF  U VVTP.EO.  - 1 ) GO  TO  S 

IF  (LWTP.NE.-1)  GO  TO  « 

?:  fail=. false. 

Of  Tl)PN 
TO  rONTINUF 

LVVAL  - -100 

IF  ( JSTA:<,HF.  JSTOOS)  LVVAl  = -1 

LVVTP  s LVVAL 


e-oTQP  ? 


SS^OP  3 

‘‘STOP  4 

‘■STOP  5 
‘■S’’OP  fi 
^<tOP  7 
‘‘STOP  0 


‘‘STOP  1C 


‘■STOP  1? 
SSTOP  13 
*^STOP  14 


SSTOP  lb 
SSTOP  17 


LVVAL  r -100 

IF  (L  VVT9.EO.  -1>  GO  TO  «*0 

FA IL= . TPUF. 

PF  Tu»N 

40  esPITGFT  (STAC<  USTOPS)  ,15, 15  ) 

JA*'=RITGET(STACK(JST0PS)  ,3  0,  1S»  ♦! 

LVVPOS  = JA$ 

LVVTVP  = 3 

LVFUNC=  ASSOC 

LVVACG:  P 

CALL  LVFINOaV?  A,LV?  B,LV?  C,LV2  01 

LVl  AAO  = P 

IF  (L  7VAL.NE.-n  LVl  AAO  = LVVAL 
TFHP  5 L VI  AAO 
LVVTP  s LVVAl 
LVVAL  r -100 

IF  (LVVTP. NE. -1)  GO  TO  50 

JSTOPS=JSTOPS-l 

LVVTP  s LVVAl 

LVVAL  = -100 

IF  (LVVTP. NE. -1)  GO  TO  30 

50  STACK( JSTOPS)  -STACK( JSTOPS)  .ANO.  7 7 7 F 70  00 0 0 T7 77 7 777 77 R 
?TAC»^(  JSTOPS)  sPI  TPUT(STACV(JSTOPS)  , JAS,3  0I 
LVVAL  = -100 

IF  ( P.NF.  TFHPI  LVVAL  * -1 

LVVTP  = LVVAl 
LVVAL  = -100 

IF  (LVVTP. NE.-n  GO  TO  40 

P s TEMP 

LVVTP  = LVVAL 
LVVAL  = -100 

IF  (LVVTP, NE, -1)  GO  TO  5 

PFTU»N 

?5Q00  CONTINUF 

LV?  A=LV?  R=LVe  C=LV2  0*0 

GO  TO  25001 

FNO 


GIRL  Version 


SUBROUTINE  SSTOP(FAIL» 

COMMON  /NEED/  ST  A RT , ASSOC , LE VEL , S TOP 

COMMON/NEEOS/STJ, JSTACK, R, JAS, J, JLAST, RTEMP, ST ACK (400» 
COMMON  /STRING/  NMN(2),STR 

INTEGER  START  .STOP,  ASSOC,  STACK,  STR  (I  )♦  ST  J*R#  TEMP 
INTEGER  BITGt T ,BI TPUT 
LOGICAL  FAIL 

execute 

JSTOPS*JSTACK 
S R4ASS0C/IC 

JSTOPS*JSTOPS^  I 

ISTCK*BITCET( STACKIJSTOPS* ,45, 15» 

STACK! JSTOPSI  « SH T FT ( IS TC K, 15 ) .OR,  SHIFT  (R, 4 51 
10  P(=STOP//20,»STOP/30  *P/5/5» 

?0  FAIL*. false. 

RETURN 

30  JSTACKtJSTOPS/40 
FAIL*. true. 

RE  TURN 

40  RsRIT&FT(STACK (JST0PS» ,15 , 151 

JAS*flITGET (ST  A CK ( JSTOPSI ,30,  15) ♦! 

P»ASSOC.JAS  'TEMP/ZSC 
JSTOPS*JSTOPS- I 
//30 

50  STACK(JSTOPS»«STACK(JSTOPS»  .ANO.  777 7 70 000 0 77 77 7 77777 B 
STACK! JS TOPS)  *RI TPUT (STACK (JS TOPS)  ,JAS  ,3  0) 

R*TEMP//40 
TEMP  *P//5 

complete 
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SUBROUTINf  ST4TNO 

STATNO 

2 

COHHON  A <M?6I  •O(500)tIOTBL(S«SQ0)«INITlOC3l«LA$TID(3l,  I$RCH(3  )« 

RICH 

2 

• JPTR,N,H, JTYP,L START *N2, IFNCNM, L OC I 0 t NX  TI 0 . ID Tt P, NI 0,  L OC * 

CY58A 

80 

2 LTTP,  IT YP, IBLK0T*H00E,IFRR, IO^S 

RICH 

4 

COMHON/LABELS/STATRA (2,200 >*NLAftEL 

STATNO 

4 

COHHON/OOLOOP/ISTACK(4,5  0» ,NST ACK , I L OOP,  lOVFtH 

STATNO 

5 

C0HM0N/6ASBL</ ISLOCK (2S00I ,NBL OCK , NB , NSR NCH 

CY56A 

26 

INTEGER  A,BLANK,STATRA 

STATNO 

7 

INTEGER  BITPUT ,BI TGET 

STATNO 

6 

DATA  BLANK/IH  / 

STATNO 

9 

c** 

THIS  ROUTINE  PROCESSES  STATEHENT  NUMBE  RS  ,B  AS  IC  BLOCKS,  ANO  00  LOOPS 

STATNO 

10 

LOC*0 

STATNO 

11 

00  S I=l,S 

STATNO 

12 

IF  (Ad)  .NE.  BLANK)  GO  TO  10 

STATNO 

13 

5 CONTINUE 

STATNO 

14 

STATEHENT  IS  UNLABELLEO 

STATNO 

15 

IFdTYP  ,NE.  18)  GO  TO  7 

STATNO 

16 

c** 

ENO  STATEHENT 

STATNO 

17 

IFdBLKOT  .EQ.  1)  RETURN 

STATNO 

IS 

STORE  NUMBER  CF  BRANCHES  IN  BASIC  BLOCK  TABLE 

STATNO 

19 

IF(N8RNCH  ,EO.  0)  GO  TO  110 

STATNO 

20 

IBLOCK IIBLKST  ) » B I TPUT ( IBL OCK (IflL  KST) ,NBRNCH, 6) 

STATNO 

21 

PE  TURN 

STATNO 

22 

c*» 

IF  FORMAT  STATEMENT,  ISSUE  DIAGNOSTIC 

STATNO 

23 

7 IFdTYP  ,EQ.  281  GO  TO  90 

STATNO 

24 

c** 

UNLABELLEO  STATEMENT  MAY  NEED  FURTHER  PROCESSING 

STATNO 

25 

IF(N8L0CK  .EQ.  0)  GO  TO  8 

STATNO 

26 

IFdBLXK(NBLOCK)  ,EQ.  998)  GO  TO  32 

STATNO 

27 

IF(NB  .EQ.  2)  GO  TO  31 

STATNO 

28 

IF(N8  .EO.  1)  GO  TO  70 

STATNO 

29 

RETURN 

STATNO 

30 

c** 

first  STATEMENT  IN  PROGRAM  - INITIALI7E  BASIC  BLOCK  TABLF 

STATNO 

31 

8 NBLOCK=l 

STATNO 

32 

GO  TO  34 

STATNO 

33 

c** 

LABELLEO  STATEMENT 

STATNO 

34 

10  IF (ITYP  .EQ.  18)  GO  TO  50 

STATNO 

35 

JPTR= I 

STATNO 

36 

c** 

GET  STATEMENT  LABEL  ANO  CHECK  THAT  IT  IS  INTEGER 

STATNO 

37 

CALL  GNLE 

STATNO 

38 

IF(JTYP  .NE.  5)  GO  TO  50 

STATNO 

39 

IF(A(6)  «NE.  BLANK)  GO  TO  50 

STATNO 

40 

IF  ( JPTP  .LT  . 6 ) GO  TO  50 

STATNO 

41 

c** 

STORE  IN  statement  NUMBER  TABLE 

STATNO 

42 

CALL  STSRCH 

STATNO 

43 

IF  (BITGF  KSTATRA  (?,LOC)  ,9, 3)  .EO.  1)  GO  TO  6C 

STATNO 

44 

c** 

SET  “OFFINEO**  FLAG 

STATNO 

45 

STATRA (2,LOC)  = BI TPUT | ST A TR A( 2 , L OC ) ,1,9) 

STATNO 

46 

IF (Lf  YP  .EQ.  9)  GO  TO  20 

STATNO 

47 

c** 

STOPE  statement  type 

STATNO 

48 

ST  at  PA (2, LOO  =«I TPUT(STATRA(?,L0C) , ITYP, 6) 

STATNO 

49 

GO  TO  30 

STATNO 

50 

20  STATpA(2,L0C)sBITPUT(STATPA(2.L0C),9.6) 

STATNO 

51 

33  IFdTYP  .EQ.  28)  RETURN 

S.TATNO 

52 

IF(NnLOCK  .EQ.  0)  GO  TO  8 

STATNO 

53 

IFINR  .EQ.  1)  GO  TO  32 

STATNO 

54 

c** 

STORf  BRANCH  FOR  RRfYIOUS  BLXK 

STATNO 

55 

31  NBLOCK=NRLOC< ♦ 1 

STATNO 

56 

IBLOCK (NBLOCK) =998 
NRPNCH=t 

c**  closf  out  prfvious  block 

3?  NR=0 

C»*  iNCPCMtNT  BLOCK  COUNTER  - START  OF  N«^XT  BLOCK 
N8L0CK=NBL0C< ♦ I 

C**  STORF  POINTER  TO  NfXT  BLOCK 

IBLOCK  UBLKST  I = BITFUT  < IBLOCK  < IPLKST*  ,NBL  CCK,?fl  ) 

C**  STORE  NO.  OF  BRANCHES 

IBLOCK  aSLKSTl  =B  I TPUT  ( IflL  OCK  a«LKSTl  ,NRRNCH,f  I 
C**  CHECK  THAT  DO  INOICES  ARE  HAOE  UNDEFINED  AT  PNO  OF  BLOCK 
J1=IBLKST*1 
J2=NBLOCK-N8PNCH- 1 
IFCTBLOCKUaT  .GT.  600C»  GO  TO  34 

?l  IFUBLOCK(Jl)  ,LT.  600  0)  GO  TO  34 
IRES=IBLOCKUl) 

DO  22  K?=J1,J21 
22  IBLOCK<K2)=IBLOCK<K2fl) 

I0LOCK(J?)=IRES 
GO  TO  21 

C**  OPEN  THE  NEW  BLOCK 

34  I8LKST=NBL0CK 
NBRNCH=0 

C**  STORE  DO  LOOP  POINTER 

IBLOCK I IBLKST  > = BITPUTI 0, ILOOP, 12) 

IF(L0C  .EQ.  0)  RFTURN 

C**  STORE  LOCATION  OF  STATEHENT  NUMBPP  OF  BLOCK 

IBLOCK  (IBLKST  ) *9  I TPUT  (I BL  OCK  ( I BL  KST  ) , L X . 36  ) 

C**  STORE  BLXK  START  IN  STATEMENT  NUMBER  TABLE 

ST  ATRA  (2*L0C)  »BI  TPUT  ($  T A T R A ( 2 , L OC  ) , I BL  KS  T,  36  ) 

IF  (91 TGE T(STATPA  (2.LOC) , IS.3)  . NE . 1)  RETURN 

IF  ( IOVFL  H .EO.  1 ) RETURN 
IF(L0C  .NE.  TSTACKd, ILOOP))  GO  TO  80 
IFIITYP  .GE,  3 .AND.  ITYP  .LE.  6)  GO  TO  100 

IF(  rrrp  ,EO.  9 .OP.  ITYP  .EO.  10  .OR.  ITYP  .EC.  17)  GO  TO  tOO 
C**  00  terminal  STATEMENT 
NB  = 2 

C**  CLOSE  OUT  LOOP 

TSTACK(2.IL00P)=1 

C*K  STORE  00  INDEX  IN  BASIC  BL OCK  TABLE 
NBLOCKsNBLOCK*  1 

IBLOCK (N8LOCK)s6000»ISTACK (4 , ILOOP) 

KL  OOP=lLOOP-l 

C**  RESET  VALUE  OF  THE  **CUPRFNT  LOOP- 
no  40  J=1 .kloop 
LOOP* ILOOP- J 

IF  (ISTACK(?,L00P)  .FQ.  1)  GO  TO  40 
IFflSTACKM  .LOOP)  .EQ,  LOO  GO  TO  35 
ILOOP=LOOP 
return 

35  ISTACK(?,L00P) =l 
N0LOCK*NBLOCK ♦ I 

IBLOCK (NBL OCK) = 6 0 00 ♦ I S TA Ck (4 ,L  OOP) 

40  CONTINUE 
ILOOP=0 
PE  TURN 


1 hi) 


STATNO  57 
STATnO  58 
STATNO  59 
STATNO  60 
STATNO  61 
STATNO  62 
STATNO  63 
STATNO  64 
STATNO  65 
STATNO  66 
STATNO  67 
STATNO  68 
STATNO  69 
STATNO  70 
STATNO  71 
STATNO  72 
STATNO  73 
STATNO  74 
STATNO  75 
STATNO  76 
STATNO  77 
STATNO  78 
STATNO  79 
STATNO  80 
STATNO  81 
STATNO  82 
STATNO  83 
STATNO  84 
STATNO  85 
STATNO  86 
STATNO  87 
STATNO  68 
STATNO  89 
STATNO  90 
STATNO  91 
STATNO  92 
STATNO  93 
STATNO  94 
STATNO  95 
STATNO  96 
STATNO  97 
STATNO  98 
STATNO  99 
STATNO  100 
STATNO  101 
STATNO  102 
STATNO  103 
STATNO  104 
STATNO  105 
STATNO  106 
STATNO  107 
STATNO  106 
STATNO  109 
STATNO  110 
STATNO  111 
STATNO  112 
STATNO  113 


50 

IEffC«3? 

STATNO 

116 

GO  TO  300 

STATNO 

115 

60 

IERC*3  3 

STATNO 

116 

GO  TO  300 

STATNO 

117 

70 

IEI?C»34 

STATNO 

118 

GO  TO  300 

STATNO 

119 

80 

IERC*35 

STATNO 

130 

GO  TO  300 

STATNO 

131 

90 

IERC'36 

STATNO 

133 

GO  TO  300 

STATNO 

133 

100 

IERC*37 

STATNO 

136 

GO  TO  300 

STATNO 

135 

tto 

IERC«3  8 

STATNO 

1 * 

?0  0 

CALL  ERRORdERO 

STATNO 

137 

RETURN 

STATNO 

138 

ENO 

STATNO 

139 

SUBROUTIte  STFNCfMFNCI 

CY58A 

67 

COHHON  * (1336)  .0  (StOI.  lOTBUS.BOOl.INITIOm  ,L  AST  ID(  3 ) , ISRCH(  3 ) . 

RICH 

3 

» JPTR.N.B,  JTYP.LSTART.N?,  IFNCBH,  LOGIOiMX  TIO,  10  TVP.NIOt  LOC  t 

CY58A 

80 

3 LTYP,  lTYP,ISLtOT,HOOE,IERR,IOES 

RICH 

6 

C0N)10N/FUNC/IENCR*IS,13I  , NARGS  , I ARGS  ( S 0)  ,FNC (.0 C( S)  , NFU NC 

CY58A 

68 

INTEGER  BITGET 

STFUNC 

5 

STATEMENT  FUNCTION  PROCESSOR 

STFUMC 

6 

>• 

GET  NO.  OF  arguments  FROM  SYMBOL  TABLE 

STFUNC 

7 

NARG<8ITCET(I0TBL  <3, LOC)  .3,6) 

STFUNC 

8 

CHECK  CORRECTNESS  OF  NO,  OF  ARGUMENTS 

STFUMC 

9 

NAR3«IFNCRA(NFNC,1) 

STFUNC 

10 

IFINARG  ,NE.  NAR3)  CALL  ERROR  ( 36  . lOTBL  (1  .LOC ) ) 

STFUMC 

11 

NARGS'MINO  (NARC.NAR3) 

STFUNC 

13 

KOUNT'O 

STFUNC 

IS 

NT«l*(NARCS-l)/6 

STFUNC 

16 

These  tno  loops  check  type  ano  dimensionality  of  arguments 

STFUNC 

15 

00  10  I«1,NT 

STFUNC 

16 

IC0Ll«-6 

STFUNC 

17 

ICOL3«-3 

STFUMC 

18 

00  10  J<1.6 

STFUNC 

19 

KOUNT«KOUNT*l 

STFUNC 

30 

IF(KOUNT  .GT.  NARGSI  RETURN 

STFUMC 

31 

IC0L1«IC0L1*B 

STFUMC 

33 

ICOL3»ICOL3*9 

STFUNC 

33 

■■9 

GET  DIMENSIONAL  I TY  - IF  NOT  0.  ISSUE  DIAGNOSTIC 

STFUMC 

36 

IF(BITGETIIFNCRA(NFNC,  I*1),IC0L3.3)  .NE.  I)  CALL  ERROR  (St  .KOUNT) 

STFUMC 

35 

9 

GET  TYPE 

STFUNC 

36 

ITP1*8ITGET  (IFNCRA(NFNC,  1*1)  .ICOL1.3) 

STFUMC 

37 

IFdTPl  .EO.  0)  GO  TO  10 

STFUMC 

38 

' 9 

CHECK  CORRECTNESS  OF  TYPE 

STFUNC 

39 

ITP3«0ITGET(IOT8L  (3,L0C*K0UNT)  .10,3) 

STFUMC 

SO 

IFdTPl  ,NE.  ITP3)  call  ERROR(51,KOONT> 

STFUNC 

31 

10  CONTINUE 

STFUMC 

33 

Rt TURN 

STFUNC 

S3 

CNO 

STFUMC 

36 

IM 

I 

L 


r 


subroutine  store 

COHHON  A(13?6)fO<SOO).IOTeL(SfSOO>,INlTlO(3).lASTIom  ,ISRCH(3 
• JPTR,  N,M,  JTYP,LSTAPT  ,N3  , I FNC  N M,  L OGI 0 • NX  T 1 0,  10  TY  P,  NI 0,  LOC  * 

^ LTYP, ITYP, IBLK0T,M0DE .lERR, IDES 

C**  this  routine  STORES  A NAHE  “NXlin-  IN  THE  SYHBOL  TABLE  AND  UPDATES 
C**  SYMBOL  table  POINTERS 
NI0*NI0^1 

IF(NID  .ST.  5 0 01  GO  TO  20 
IMINITIonOTYPI  .NE.  0>  GO  TO  5 
INITIO  aOTYP)  = NIO 
S CONTINUE 

rOTet (1,NI0>=NXTI0 
IOTBL (2,NIOI=0 

IFILASTIOdOTYPI  .EQ.  0)  GO  TO  10 
LAST  = LASTI0(I0TVPI 
IOTBL (2.LASTI =NIO 
10  LASTIO (IOTYP) =NIO 
RE  TURN 

20  HRrTf(6,?5> 

25  FORMAT  (/////5X  .l»6H  SYMBOL  TABL^  OVERFLOW  - PROCESSING  TERMINATED) 
STOP 
FNO 


SUBROUTINE  STSPCh  STSRCH 

COMMON  A(13?6),0«500)*IOTRL(^*^00)*INITIO<3),LASTIOI3), ISRCH(3 ) • RICH 
• JPTP,N,M, JTVP ,LS tartan?,  IFNCNH.LOGIO  »NK  TIO,  10  TYP , N ID  * LOC « CY5AA 

2 LTYP,  ITYP,  IBLKOT  ,mO0E  , lERR,  lO'^S  RICH 

COMMON/L ABELS/STA  TrA  1 2 , 20  0 ) *NL  ABEL  STSRCH 

INTEGER  STATPA  STSRCH 

C**  this  ROUTINE  SEARCHES  THf  STATEMENT  NUMBER  TABLE  AND  STORES  THF  STSRCH 

C**  NUMBER  IN  THE  YABLE  IF  NOT  FOUND  STSRCm 

IF(NLABEL  .EO.  0)  GO  TO  15  STSRCH 

00  10  I*1,NLABEL  STSRCH 

IF <STATRA  (1,1 ) .NE.  N2)  GOTO  IC  STSRCH 

C**  STATEMENT  NUMflCR  FOUND  IN  TABLE  • RETURN  KXATION  WHERE  FOUND  SYSPCH 

LOC=I  STSRCH 

RETURN  STSRCH 

10  CONTINUE  STSRCH 

C**  statement  number  not  FOUNO  - INCREMENT  COUNTER  STSRCH 

15  NLABFLsNLABEL^I  STSRCH 

IF(NLABFL  .or.  20  0 » go  to  20  STSRCH 

C**  STORE  statement  NUMBER  AND  RETURN  LOCATION  WHERE  STORED  STSRCH 

LOCsNLABFl  STSRCH 

STATRA (I ,LOC) *N2  STSRCH 

RETURN  STSRCH 

23  WR  ITE  25)  STSRCH 

25  FORMAT  (/////5<  .53M  STATEMENT  NO.  TABLE  OVCRFION  - PROCESSING  TFRMl  STSRCH 
•NATEO)  STSRCH 

STOP  STSRCH 

END  STSRCH 


SUBPOUTINf  SUB 

COHHON  A{1336),O(500),IOTBLf6,S0QI,INlTIO(3»fLASTIO(3)  ,I$RCH(3  >• 
• JPTR,N,M, JTVP,tSTAPT, N?, IFNCNM.lOGIOfNXTIO* 10  TYP,NI0*L0C. 

2 LTYP,  ITYP,  I8L<OT,MOO€:,  lERP,  I OPS 
DIMENSION  IALPHI10),IALPH?(8),KT(5> 

INTEGER  BLANK.COMMA,RPAR,A,0 
INTEGER  BITPUT 

DATA  <IALPH(I)  fI*l,lO)/lHS,lHU,lH0,lHR,lHO,lHU,lHT,lHI,lMN,lHE/ 
DATA  ( IALPM2( I ) * I = 1 , 8 ) /I  he ,i HU . I HN , 1 HC 1 1 NT , 1 HI ,l HOt IMN/ 

DATA  (KT  ni  tl  » l,5»/lHR,lHCtlH0. 1HI,1HL/ 

DATA  BLANK/IH  / , L PAR/ 1 H C / , RP AR / 1 H ) / , C OHM  A/ 1 H , / 

C**  SUBROUTINE  ANO  FUNCTION  STATEMENT  PROCESSOR 
NARO^O 
ISTATE=0 

IF  aiTP  .EQ.  30>  GO  TO  S 
C**  FUNCTION  STATEMENT 

2 00  3 1=1,8 

IF  (NEXT  (JPTR)  ,NE.  TALPH2IIU  GO  TO  50 

3 CONTINUE 
GO  TO  12 

C**  SUBROUTINE  STATEMENT 
5 00  10  1=1,10 

IMNEXTUPTR)  ,NE.  IALPH(I))  GO  TO  50 
10  CONTINUE 
GO  TO  17 

12  IPTRsJPTR 
IFRST  = NEXTm 

IMIFRST  ,EQ,  IHFI  GO  TO  14 
C**  FUNCTION  IS  A TYPED  FUNCTION,  GET  TYPE 
DO  13  1=1,5 

IFCIFRST  .NE.  KT(in  GO  TO  13 

ISTATE=I 

GO  TO  14 

1 3 CONTINUE 

14  JPTR=IPTR 

C**  GET  NAME  OF  SUBROUTINE  OP  FUWTTON  AND  STORE  IN  SYMBOL  TABLE 
17  CALL  GNLE 

IFIJTYP  ,NE,  2)  GO  TO  50 

I0TYP=2 

CALL  STORE 

IE»0(l  » 

IFUTYP  ,NE.  31)  GO  TO  15 
C**  ^UNCTION  must  be  FOLLOMEO  by  ARGUMENT  LIST 
IF  (Nc  XT  ( JPTR)  ,NE.  LPAR)  GO  TO  50 
IFNCNM  = N<TI0 
GO  TO  20 

15  IF  (NEXT  ( JPTR>  ,EQ,  BLANK)  GO  TO  30 
IF(A(JPTR“1)  .NE.  LPAR)  GO  TO  50 

C**  GET  NEXT  ARGUMENT 
20  CALL  GM.E 

IF  (JTYP*  .NE.  2)  GO  TO  60 
CALL  search 

IFdSRCHd)  ,NE.  0 .OR.  ISRCMC2)  ,NE.  0)  CALL  ERROR  < 8 6 , NXT  1 0 ) 

lOTYPsl 

CALL  STORE 

C**  SET  -formal  parameter-  FLAG 

IOTBL  ( T,NIO»s  B ITPUTdOTflt  n,NI0),t.l2) 


SUB 

2 

RICH 

2 

CY58A 

80 

RICH 

4 

SUB 

4 

SUB 

5 

SUB 

6 

SUB 

7 

SUB 

8 

SUB 

9 

stm 

10 

SUB 

11 

SUB 

12 

SUB 

13 

SUB 

14 

SUB 

15 

SUB 

16 

SUB 

17 

SUB 

18 

SUB 

19 

SUB 

20 

SUB 

21 

SUB 

22 

SUB 

23 

SUB 

24 

SUB 

25 

SUB 

26 

SUB 

27 

SUB 

28 

SUB 

29 

SUB 

30 

SUB 

31 

SUB 

32 

SUB 

33 

SUB 

34 

SUB 

35 

SUB 

36 

SUB 

37 

SUB 

38 

SUB 

39 

SUB 

40 

SUB 

41 

SUB 

42 

S)IB 

43 

sue 

44 

SUB 

45 

sue 

46 

SUB 

47 

SUB 

48 

S)IB 

49 

SUB 

50 

SUB 

51 

SUB 

5? 

SUB 

53 

SUB 

54 

SUB 

55 

SUB 

56 

I < 


C**  INCI^EHtNT  ARGUHENT  COUNTER 

SUB 

57 

NARGsNARO^l 

SUB 

SO 

IFCMEXTUPTRI  ,£0.  RPARI  GO  TO  30 

SUB 

S9 

IFUIJPTR-1)  .NE.  COMMA!  GO  TO  SO 

SUB 

60 

GO  TO  20 

SUB 

61 

30  LOC«l 

SUB 

62 

t)(ll<IE 

SUB 

63 

C**  check  no*  of  ARGUMENTS  AND  STORE  IN  STMBOL  TABLE 

SUB 

64 

IFCNARG  .GT*  631  CALL  ERROR(031 

SUB 

65 

lOTBL  « 3»L0C1  = B ITPUTIIOTBL  <3*L0C1 ♦NARGtTl 

SUB 

66 

IF  (ITTP  *EO*  301  RETURN 

SUB 

67 

IFIISTATE  #EO.  01  GO  TO  SS 

SUB 

60 

C**  IF  TYPED  FUNCTION,  STORE  TYPE  ANO  SET  "TYPE  SET-  FLAG 

SUB 

69 

lOTBL  < 3,L0C1  = B ITPUT< IOTRL 1 3*  LOCI , ISTATE* 101 

SUB 

70 

lOTBL  (3f  L0CM9ITPUT  (tOTBL  (3,L0C1  « 1, 11  1 

SUB 

71 

return 

SUB 

72 

C**  SET  FUNCTION  TYPE  IMPLICITLY 

SUB 

73 

55  CALL  IMPTYP 

SUB 

74 

RETURN 

SUB 

75 

SO  CALL  ERRORfTl 

SUB 

76 

RETURN 

SUB 

77 

60  CALL  ERRORfSe, NXTIOl 

SUB 

70 

return 

SUB 

79 

END 

SUB 

00 

SUBROUTINE  SUBCHK 

SUBCHK 

2 

COMMON  A(13?6)»0(SOai,IOTBUa»SOO)«INITIO<3>«LASTIOf3),  ISRCHf  3 ), 

RICH 

2 

• JPTR*N,M,  JTYP,L  START  *N2,  IFHCNM,  LOGIC,  NX  T 10,  10  TY  P,  NIO  , LOC  , 

CY56A 

80 

2 LTYP, ITYP, IBL  X0T,M00E,IERR, lOFS 

RICH 

k 

common/global /NBLX,NREF,NSUBS, BLXTBL  f 200  IfEXTTBt (100) • ISUBSI 100) 

SUBCH< 

C0MM0N/LIST/NLIST,NINTFC,ISUBLT (2,200) fINTFACI 300) 

SUBCHK 

5 

INTEGER  BITPUT,BITGET 

SUBCHK 

6 

c*» 

after  PROCESSING  OF  THE  MODULE  IS  COMPLETED,  THIS  ROUTINE  IS  CALLED 

SU0CHK 

7 

C*‘ 

TO  PROCESS  THE  SUBROUTINE  NAME  AND  ARGUMENT  LIST 

SUBCHK 

8 

IFdPLKOT  .EQ,  1)  RETURN 

SUBCHK 

9 

c»» 

INCREMENT  SUBROUTINE  COUNTER 

SUBCHK 

10 

NSuessNSuesfi 

SUBCHK 

11 

IF(NSU6S  ,GT.  100)  GO  TO  50 

SUBCHK 

12 

c»» 

GET  number  of  ARGUMENTS  ANO  TYPE 

SUBCHK 

13 

NARG^BITGETdOTBL  (3,1)  ,7,6) 

SUBCHK 

Ik 

ITP=BITGET(I0TBL (3,1),10, 3) 

SUBCHK 

15 

IF(BITGET(I0TBL(3,1),18,1)  ,EQ,  1)  GO  TO  15 

SUBCHK 

16 

c»» 

MODULE  ARGUMENT  LIST  HAS  NOT  YET  BEEN  ENCOUNTERtC  - SET  FLAG 

SUBCHK 

17 

IOT6L(5,1)«0ITPUT(IOTBL( 3,1) ,1,10) 

SUBCHK 

18 

c»» 

search  SESCOMP  LIST 

SUBCHK 

19 

00  5 I«1,NLIST 

SUBCHK 

20 

IFdOTBLd.l)  «NE,  ISUBLTd,!))  GO  TO  5 

SUBCHK 

21 

c»» 

NA»C  FOUND  IN  5ESCOMP  LIST 

SUBCHK 

22 

LISTlC*! 

SUBCHK 

23 

c»» 

STORE  LIST  LOCATION  IN  SYMBOL  TABLE 

SUBCHK 

2% 

IDTBL  ( 3,  D'BITPUT  (IOTBL  ( 3, 1)  ,L  ISTLC,36) 

SUBCHK 

25 

GO  TO  20 

SUBCHK 

26 

5 CONTINUE 

SUBCHK 

27 

c»» 

NAME  NOT  FOUND  IN  SESCOMP  LIST  - ISSUE  DIAGNOSTIC 

SUBCHK 

28 

CALL  ERROR(52) 

SUBCHK 

29 

c»» 

ADO  NAME  TO  SESCOMP  LIST 

SUBCHK 

30 

NLlST»NLlSm 

SUBCHK 

31 

ISU8LT(1,NLIST )«IOT0L (If  1) 

SUBCHK 

32 

c»» 

ADO  NAME  TO  SUBROUTINE  TABLE 

SUBCHK 

33 

ISUBS (NSUBS)»NLIST 

SUBCHK 

36 

ISU8LT(2,NL IST)«0 

SUBCHK 

35 

c»» 

STORE  LIST  location  IN  SYMBOL  TABLE 

SUBCHK 

36 

lOTBL (3, l)«eiTPUT(I0TBL(3,l) ,NLIST,3$) 

SUBCHK 

37 

IF(NARG  ,EQ.  0)  RETURN 

SUBCHK 

38 

c»» 

MODULE  HAS  ARGUMEMTS-STORE  ATTRIBUTES  IN  INTERFACE  DEFINITION  TABLE 

SUBCHK 

39 

IPTR=NINTFC^1 

SUBCHK 

60 

c*» 

STORE  POINTER  TO  INTERFACE  DEFINITION  TABLE  AND  NUMBER  OF  ARGS. 

SUBCHK 

61 

ISUBLT  (2,NLlSr  IsBiTPUT  dPTR,NARG,6) 

SUBCHK 

62 

c*» 

STORE  TYPE 

SUBCHK 

67 

ISU0LT(2,NLIST)»0ITPUT (ISUBLT(?,NLIST) ,ITP,1 3) 

SUBCHK 

66 

NlNTFC*IPTR*(NARG-l)/6 

SUBCHK 

65 

kount<o 

SUBCHK 

66 

c»* 

THESE  TWO  LOOPS  CONSTRUCT  THE  INTERFACE  DEFINITION  FOR  THE  MODULE 

SUBCHK 

67 

DO  10  IsIPTRfNINTFC 

SUBCHK 

68 

INTFACd)*0 

SUB CHK 

69 

ICOLl*-6 

SUBCHK 

50 

ICOL2»-3 

SUBCHK 

51 

DO  10  J»l,6 

SUBCHK 

52 

KOUNT«KOUNTM 

SUBCHK 

53 

IFIKOUNT  «GT«  NARG)  RETURN 

SUBCHK 

56 

ICOL1»ICOL1»B 

SUBCHK 

59 

ICOL2«ICOL2»B 

SUBCHK 

56 

"1 


C**  G£T  TYPE  ANO  01 HFNS  lONAL  IT  Y Of  NFKT  APGUHFNT 

SUBCHK 

57 

ITP=BITGFT  U0T9H  5,K0UNT  ♦!  > ,10  . 3> 

SUBCHK 

56 

N0lM=8lTGFTa0TBL  <3,K0UNT*1I  , 7 , » 

SUBCHK 

59 

IOTBL (3.K0UNT ♦ 1>  = BITPUT ( lOTBL ( 3,koUNT ♦!»  ,1,3  71 

SUBCHK 

60 

C**  STOPF  IN  INTERFACe  DEFINITION 

SUBCHK 

61 

INTfAC(n*BITPUT(INTFAC(n,ITP,ICOLl) 

SUBCHK 

62 

10  INTFAC  < n sQITPUT  ( INTFAC( 1 1 .NOI N, ICOL ^ » 

SUBCHK 

63 

PETUPN 

SUBCHK 

64 

C**  HOOULE  PPfVlOUSLY  ENCOUNTEPEO  - GfT  SESCOHP  LIST  LOCATION 

SUBCHK 

65 

C**  FROH  SYMBOL  TA3LE 

SUBCHK 

66 

IS  LISTlC  = BITGET  1 rOTBLi  3,1>  ,36,  9) 

SUBCHK 

67 

C**  STORE  NAHF  in  SUBROUTINE  TABLE 

SUBCHK 

66 

?Q  ISUBS(NSURSI=L ISTlC 

SUBCHK 

69 

C**  GET  MODULE  CLASS  AND  NO.  OF  ARGUMENTS 

SUBCHK 

70 

KL  ASsBITGET (ISUBLT  <?,LISTlCI ,10,41 

SUBCHK 

71 

NAR2rBITGET  Cl  SU8L  T C 2,  L IS  T LC » ,6,6» 

SUBCHK 

72 

c**  cnecif  NO.  of  arguments 

SUBCHK 

73 

IFCNARG  .NE,  NAR?)  CALL  E PROP C 26 * IOTBL <1  • 1 M 

SUBCHK 

74 

NAPGS'MINO  (NARGf  NAR2) 

SUBCHK 

75 

C**  CHECK  TYPE 

SUBCHK 

76 

IF  IITP.NE.BITGET  C ISUBLTC  2,LISTLCJ ,13, 3 ) I call  E PROP (4  9, IOTBL ( 1,  IM 

SUBCHK 

77 

ifcnargs  .eo.  o»  return 

SUBCHK 

78 

C**  MODULE  HAS  ARGUMENTS  - CHECK  INTFPFACE  DEFINITION  FOR 

V«L  IDITr 

SUBCHK 

79 

C**  COMPUTE  INTERFACE  DEFINITION  TABLE  POINTERS 

SUBCHK 

60 

IPTR=8ITGETCISUBLT  (2,LISTLCI  ,60,151 

SUBCHK 

61 

NOPTR=IPTR*  (NARGS-n  /6 

SUBCHK 

82 

K0UNT=C 

SUBCHK 

63 

C**  THESE  TMO  LOOPS  CHECK  THE  ARGUMENTS  AGAINST  THE  INTERFACE  DEFINITION 

SUBCHK 

64 

00  25  I=IPTR,N0PTR 

SUBCHK 

65 

rCOL  l®-6 

SUBCHK 

66 

ICOL2=-3 

SUBCHK 

87 

no  25  J=l,6 

SUBCHK 

66 

K0UNT=K0UNT^1 

SUBCHK 

69 

IFCKOUNT  ,GT.  NARGS)  RETURN 

SUBCHK 

90 

XC0L1sIC0L1^9 

SUBCHK 

91 

IC0L2*IC0L2*9 

SUBCHK 

92 

C**  GET  TYPE  ANO  DIMENSIONALITY  FROM  INTERFACE  DEFINITION 

TABLE 

SUBCHK 

93 

ITP  = BITGET(INTFAC  CI»,IC0L1,3I 

SUBCmk 

94 

N0IH=BITCET  CINTFACC  I>  f ICOL2,  31 

SUBCHK 

95 

C**  GET  TYPE  ANO  DIMENSIONALITY  FROM  SYMBOL  TABLE 

SUBCHK 

96 

ITP2=9ITr,eT(I0TBL  C3,KOUNT*l)  , 10,3> 

StiBCHK 

97 

N0IM2SBITGETC IOTBL (3,K0UNT ♦!» ,7,6) 

SUBCHK 

98 

C**  GET  I/O  STATUS  FROM  INTERFACE  DEFINITION  TABLE 

SUBCHK 

99 

I0STAT=9TTCET  C INTFACC  I)  , IC0L2^  3,3) 

SUBCHK 

100 

IFCIOSTAT  ,EO,  2 .OR.  KLAS  . EO . 0)  lOSTAT*! 

SUBCHK 

lOl 

IOTBL  C3,K0UNT>1 ) =B IT PUTC IOTBL  C 3,K0UNT»1)  , IOSTAT, 37) 

SUBCHK 

102 

C**  CHECK  dimensionality 

SUBCHK 

103 

IFCNOIM  ,NF.  N0IM2)  CALL  ERROR ( 50 ,KOUN T) 

SUBCHK 

104 

IF  (ITP2  .NE.  0 ) GO  TO  23 

SUBCHK 

105 

ITP2* 1 

SUBCHK 

106 

IFSTrBITGET (I  0T9L (1,K0UNT4  1)  ,6,6) 

SUBCHK 

107 

IFCIFST  ,LE.  14  .ANO.  TEST  , GE . 9)  ITP2*4 

SUBCHK 

106 

C**  CHECK  TYPE 

SUBCHK 

109 

IFCtTP  .ME.  ITP2)  CALL  E RROR  < 5 1 , K OUNT) 

SUBCMK 

110 

25  CONTINUE 

SUBCHK 

111 

RETURN 

SUBCHK 

112 

50  CALL  ERROPC25) 

SUBCHK 

113 

STOP 

SUBCHK 

1 14 

ENO 

SUBCHK 

115 
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subroutine  snitch  Snitch 

COMHON  t(1326),0(SaO)tIOT8L(S.500I.INITID(3t.L*STIOI3l  ,ISRCH(3I,  RICH 
• JPTR.N.N, JTTP.L START, N2, IFNCNM, L OGI 0 , NX  TIO, 10 TTP ,NIO , LOC , Cr58» 

2 lttp,ittp,iblkot,hooe,ierr,iofs  rich 

C»*  this  routine  .NITCHES  the  STHSOt.  TABLE  STORAGE  OF  A NAME  FROM  SNITCH 

C»»  VARIABLE  TO  FUNCTION  SNITCH 

00  20  I=t,NIO  SNITCH 

IF(I0IBL(2,H  .NE.  LOC)  GO  TO  20  SNTTCH 

I0TBLI2.I)*I0TBL  <2,L0C)  SNITCH 

C*»  CHANGE  SYHBOL  TABLE  POINTER  SNITCH 

IF(LASTIOU)  .EQ.  LOC)  LASTI0(1)«I  SNITCH 

GO  TO  30  Snitch 

20  CONTINUE  SNITCH 

INITIOa)«IOTBL  (2,L0C)  SNITCH 

C»*  AOO  NAHE  TO  FUNCTION  LIST  SNITCH 

30  IAST  = LASTI0(2)  SNITCH 

lOTBL C2,LAST) «L0C  SNITCH 

I0T8L  (?,LOC)  = fl  SNITCH 

LASTIO  (2)  *L0C  SNITCH 

CALL  ERRORI87, IOT8L(1,LOC) ) SNITCH 

RETURN  SNITCH 

ENO  SNITCH 
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StiBffOUTINe  STMTAB 

SYMTAB 

2 

COHHON  *«1326) ,OI50a).IOTBL(8,500).INITtDI3) .L «STIO(3) , ISRCHI3 1. 

RICH 

? 

» JPTP.N,  H,  JTyp.L  START,  N?,  I FNCNH,  LOCI  0 . NX  TI D , TO  TY  P,  NID  , LOC  , 

CY5  8A 

SO 

2 LTYP, ityp.iblkot.hooe .IERR.IOES 

RICH 

4 

CONHON/t A8ELS/STATRA 1? • ?00 ) 9 NL ABEL 

SYMTAB 

4 

COMMON/LIST/NLIST,NINTFC,ISUBLT  (2,200*  ,INTF*C(  3001 

SYMTAB 

5 

COHMON/STFUfC/NSTFNCfISTFNCaO  » 

SYMTAB 

6 

DIMENSION  IUBEU5I 

SYMTAB 

7 

INTEGER  TYPE* 5), DIMS (3  *, BITGET , ST ATR» 

SYMTAB 

6 

DATA  ITYPECI*  ,I»1,S*/i.mREAL,6HC0MPLX,6H0  0UBLE,  6MINTEGR,6ML0GICL/ 

SYMTAB 

9 

DATA  kOIHSai  9 

SYMTAB 

10 

c»»  THIS  routine  Displays  the  symbol  table 

SYMTAB 

11 

IFfNIO  .LE*  1)  RETURN 

SYMTAB 

12 

IFdBLKOT  .EQ,  1*  60  TO  2 

SYMTAB 

13 

INTL*INITIO(2» 

SYMTAB 

K. 

c»»  display  heading 

SYMTAB 

15 

MRITE(6,1)  lOTBL  (1,INTLI 

SYMTAB 

16 

1 F0RMAT(//////%5X,25H  SYMBOL  TABLE  FOR  MODULE  9A6» 

SYMTAB 

17 

GO  TO  4 

SYMTAB 

16 

2 t(RITE(6,3l 

SYMTAB 

19 

3 FORMAT  (////F/%6X,2«H  SYMBOL  TABLE  FOR  BLOCK  DATA* 

SYMTAB 

20 

A LOC*INITIOIlt 

SYMTAB 

^l 

IFCLOC  .EQ,  0*  GO  TO  20 

SYMTAB 

22 

C»»  DISPLAY  variables 

SYMTAB 

23 

WRITE(6,5* 

SYMTAB 

24 

S FORMAT  C//56X,  9HVARI ABLES/30X * 4HNAME 9 1 AHTYPC  931 V9I ttHRCLOCA TI ON ) 

SYMTAB 

25 

100  ITABEL(l)*IOTBL(l,LOCI 

SYMTAB 

26 

C»*  SKIP  IF  NOT  USED 

SYMTAB 

27 

IF(BITGETIIOTBL(3, LOC)  ,11,11  ,EQ.  01  GO  TO  27 

SYMTAB 

28 

C*»  GET  TYPE 

SYMTAB 

29 

I<BITGET(IOTBL (3,LOCI  ,10,3) 

SYMTAB 

30 

ITA0EL<?l»TYPe(H 

SYMTAB 

31 

IF(BITGETIIOTBL(3,LOC),l,l)  .EO.  0)  GO  TO  16 

SYMTAB 

32 

C»»  GET  dimensionality 

SYMTAB 

33 

ITABEU3)«5HARRAY 

SYMTAB 

34 

I*SIT6ET«I0TBL  (3, LOC*  ,7,6) 

SYMTAB 

35 

ITABEL  C4I«0IMS  III 

SYMTAB 

36 

GO  TO  IS 

SYMTAB 

37 

16  ITABEL (3)«1H 

SYMTAB 

36 

ITABEL  <41  >1N 

SYMTAB 

39 

18  IFIBITGET(IOTBL<3, LOC)  ,12,1)  ,EQ.  0)  GO  TO  20 

SYMTAB 

60 

C»»  VARIABLE  IS  FORMAL  PARAMETER 

SYMTAB 

41 

ITABEL  (S)*BHF,  P. 

SYMTAB 

42 

GO  TO  25 

SYMTAB 

63 

20  IFIBITGET(IOTBLI3, LOC), 16,1)  ,EQ,  1)  CO  TO  22 

SYMTAB 

44 

ITABEL (5)<1N 

SYMTAB 

49 

GO  TO  25 

SYMTAB 

46 

C»»  VARIABLE  IN  COMMON  - GET  COMMON  BLOCK  NAME 

SYMTAB 

47 

22  ICONNM«IOTBL(6 ,LOC) 

SYMTAB 

40 

ITABEL  (5)«I0rSL(l,IC0MNH) 

SYMTAB 

49 

IF(ITABELI5)  .EQ.  IM  ) ITABEL *5) ■2H// 

SYMTAB 

50 

C*»  DISPLAY  LINE 

STHTOa 

51 

25  MRITEI6.26)  ( I TABEL  II)  .1  *1  .5 ) 

SYMTAB 

52 

26  FORMATI30X.A6, 11X,A6,16X,A5,1X,A1,7X,A6) 

SYMTAB 

53 

27  LOC«IOTBLI2.LOC) 

SYMTAB 

56 

IF<LOC  bNE*  01  GO  TO  180 

SYMTAB 

55 

28  IFIIBLKOT  .EQ.  1)  GO  TO  60 

SYMTAB 

56 

L0C*I0TBL  (2tl ntl  ) 

SYMTAB 

57 

IFILOC  .fO.  0)  GO  TO  6C 

SYMTA0 

58 

C**  DISPLAY  EYTfPNALS 

SYMTAB 

59 

WRITE I6»  31) 

symtab 

60 

31  FORMAT  (//55X,  lOH  EYTERNALS/4UX , 4HNAME , 

10  X,4HTYPE,  10X,4HARGS) 

SYMTAB 

61 

30  ITABEL(1)  = I0TBLU*L0C) 

SYMTAB 

62 

C**  GET  SESCOMP  list  LOCATION 

SYMTAB 

63 

LISTlC=BITGETUOT0L(3,LOCI,36*B) 

SYMTAB 

64 

IF  CLISTlC  .EO.  0 » go  to  39 

SYMTAB 

65 

C**  GET  TYPE 

SYMTAB 

66 

ITP=BITGET ( ISURLT(?,LISTLC) *1  3,3) 

SYMTAB 

67 

IF  ( ITP  . EQ.  0)  GO  TO  3? 

SYMTAB 

66 

IT  ABEL I2)sTypE(ITPI 

SYMTAB 

69 

GO  TO  3S 

SYMTAB 

70 

32  ITA0EL(2)=1H 

SYMTAB 

71 

35  IF(eiTGETaSU8LTf2,LISTLC)  tlW,!)  .EQ. 

1)  GO  TO  37 

SYMTAB 

72 

C**  GET  NUMBER  OF  ARGUMENTS 

SYMTAFJ 

73 

ITABEL<3)=BITGETI  ISUBL T C 2 , LI  ST L C ) ,6.6) 

SYMTAB 

74 

c**  display  line 

SYMTAB 

75 

WRITE(6,36)  ( ITABEU  I)  »I=1.3) 

SYMTAB 

76 

36  FORMAT (44X,AS, ax. A6,8X, 12) 

SYMTAB 

77 

GO  TO  39 

SYMTAB 

78 

37  WRITE(6,36»  I T A BFM 1 ) . I T ABEL  ( 2 > 

SYMTAB 

79 

35  FOPMAT(44X,A6,8X,A6.0X,2H>1) 

SYMTAB 

80 

39  L0C=I0TBL(2.L0C) 

SYMTAB 

81 

IF  ILOC  . NE.  0 ) GO  TO  3C 

Sym  tab 

62 

60  IFJNSTFNC  .EQ.  0)  GO  TO  40 

SYMTAB 

83 

c**  display  statement  functions 

SYMTAB 

64 

WRITE (6,62) 

SYMTAB 

85 

62  format <//53X,  20H  STATEMENT  FUNCTIONS/ 

SYMTAB 

86 

$ 44 X, 4HNA ME, lOX, 4 HTY PE, 1 0 X,4HARGS ) 

SYMTAB 

87 

no  70  i=i,nstfnc 

SYMTAB 

66 

C**  GET  SYMBOL  table  LOCATION 

SYMTAB 

69 

LC=ISTFnC<I) 

SYMTAB 

90 

C**  GET  TYPE 

SYMTAB 

91 

ITPsBITGET  (IDTBL  ( 3,LC)  ,10,  3) 

SYMTAB 

92 

C**  GET  number  OF  ARGUMENTS 

SYMTAB 

93 

NPG*BITGfT (lOTBL ( 3,LC) ,7,6) 

SYMTAB 

94 

C**  DISPLAY  LINE 

SYMTAB 

95 

70  WPITECe.ie)  lOTBL  (l,LC), TYPE  (ITP)  , NRG 

SYMTAB 

96 

40  IF(NLARCl  .EO.  0)  GO  TO  SO 

SYMTAB 

97 

c**  display  statement  numbers 

SYMTAB 

98 

WRITE (b,4?» 

SYmTAB 

99 

42  FORMAT (//SIX, 1 7M  statement  LABELS) 

SYMTAB 

100 

WRITE  (6, 4S)  (STATRAtl,!),  1»1,NLARFl) 

SYMTAB 

101 

45  FORMAT (40X,5I8 ) 

SYMTAB 

102 

00  47  Ial,NLl0fL 

SYMTAB 

103 

IF (01 TGE T (STAT PA (2, I ) , 9,  3)  . NF . 1)  CALL  F PRO R(  IS , ST  A T R A ( 1 , 1 ) 1 

SYMTAB 

IC4 

IF  (BI  TGE  T (STATRA  ( 2,  n , 12  . 3)  .NE.  11  CALL  ERROR  11  F , S T A T A A f 1 , 1 I ) 

SYMTAB 

105 

47  CONTINUE 

SYMTAB 

106 

SO  L0C»INIT10(3I 

SYMTAB 

107 

IF(L0C  .EO.  0)  RETURN 

SYMTAP 

108 

c**  display  common  BLOCXS 

SYMTAB 

109 

WRITE (6,52) 

SYMTAB 

110 

52  FORMAT (//53X, 1 4M  COMMON  RL X XS / 5 0 X , 4Hn AMf , 1 0 *, 6Mi f nC T H ) 

SYMTAB 

111 

SI  ITABEL (1 ) * rOTBL (1  ,LOC) 

SYMTAB 

112 

IFdTARELd)  .EO.  | 1 T A BE  L ( 1 ) » 2m// 

SYMTAB 

113 

WP  ITE  (6 ,55)  I T ABE  L d ) . IOTBL(4,  LOO 

SYMTAB 

114 

55  FORMAT (SOX, A6, 8X,  18) 

SYMTAB 

115 

loc*iotbl  (2, loo 

SYMTAB 

116 

IF  (LOC  .NE.  0)  GO  TO  St 

SYMTAB 

117 

Pf  TURN 

SYMTAB 

118 

f NO 

SYMTAB 

119 

If1‘) 
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SUBROUTINE  TYPE 

TYP  E 

2 

COMMON  A (1336) , D ( 500 1 * IOTBL ( 6 • 5 0 0 ) • IN XTI 0( 3 ) ,L  AST 10 ( 3 ) »ISRCH( 3 1 • 

RICH 

2 

• JPT«*N,M,JTYP,LSTART,N2, rFNCNH,LOGIO*H*TIO, lOTYPtNiDtLOC, 

CV58A 

SO 

2 LTYP,  ITYP,IBL«(OT,MOOE*IERP.IOES 

RICH 

4 

DIMENSION  lALPMl  (7)  * lALP  H2(7)  . IALPH3  (%),  lALPH^  (7  ) , lA  LPM?  C 15 ) • 

TYPE 

4 

1 I0IM(3) 

TYPE 

5 

INTEGER  A«RPAR«COMMA, BLANK 

TYPE 

6 

INTEGER  9ITPUT,BITGET,C0MLX 

TYPE 

7 

DATA  CIALPHK  I ) , I«1.7)  /IHL.IHO,  IMGflHI  ,1  HC»1  HA  ,IML/, 

TYPE 

S 

1 (IALPH2(I) ,I«1,7)  /1HI,1HN,1HT,1HE.1HG* IME.IHR/, 

TYPE 

9 

2 CIALPH3(r),r*l*4»)/lHR,lHE,lHA,iHL/t 

TYPE 

10 

3 (lALPH^m  *Is1,7I/1HC,1H0,1HM,1HP,IML  tlHE^lHX/, 

TYPE 

11 

4 ( IALPHS( I) ,1* 1, 151/lHO* IHO, IHU. IHB.IHL* IHE* IHP, IMR, IHE.IHC, 

TYPE 

12 

5 IMI,IH$,1HI,IH0,1HN/ 

TYPE 

13 

DATA  LPAR/1H(/,RPAR/1H)/,COMHA/1H»/,0LANK/1H  / 

TYPE 

14 

c**  type  statement  processor 

TYPE 

15 

MUL*1 

TYPE 

16 

ITsITYP-ie 

TYPE 

17 

GO  TO  (10.2Q,  30,40«50) ,IT 

TYPE 

18 

C**  INTEGER  STATEMENT 

TYPE 

19 

10  DO  15  1*1,7 

TYPE 

?0 

IF (NEXT ( JPTR)  ,NE#  IALPH2(I))  GO  TO  110 

TYPE 

21 

15  CONTINUE 

TYPE 

22 

ISTATE=4 

TYPE 

23 

GO  TO  60 

TYPE 

24 

C**  REAL  STATEMENT 

TYPE 

25 

20  DO  25  1*1,4 

TYPE 

26 

IF  <NEXT(  JPTR)  .NE.  lACPHTdll  GO  TO  110 

TYPE 

27 

25  CONTINUE 

TYPE 

26 

ISTATE*! 

TYPE 

29 

GO  TO  60 

TYPE 

30 

C**  OOU6LE  PRECISION  STATEMENT 

TYPE 

31 

30  DO  35  1*1,15 

TYPE 

12 

IF (NEXT ( JPTR)  ,NE.  IALPH5(I)1  GO  TO  110 

TYPE 

33 

35  CONTINUE 

TYPE 

34 

WL*2 

TYPE 

35 

ISTATE*3 

TYPE 

36 

GO  TO  60 

TYPE 

37 

C**  complex  STATEMENT 

TYPE 

38 

40  DO  45  1=1,7 

TYPE 

39 

IFINEXT( JPTR)  ,NE.  IALPH4(I)>  GO  TO  110 

TYPE 

40 

45  CONTINUE 

TYPE 

41 

WL*2 

TYPE 

42 

ISTATE=2 

TYPE 

43 

GO  TO  60 

TYPE 

44 

C**  LOGICAL  statement 

TYPE 

45 

50  DO  55  1*1,7 

TYPE 

46 

IF  (NEXT  (JPTR)  ,NF.  lALPHKD)  GO  TO  110 

TYPE 

47 

55  CONTINUE 

TYPE 

48 

ISTATE=5 

TYPE 

49 

60  ISUR*0 

TYPE 

50 

INCRsMUL 

TYPE 

51 

C**  GET  NEXT  variable  IN  TYPE  STATEMENT 

TYPE 

52 

CALL  GNLE 

TYPE 

53 

IF(JTYP  ,NE.  2)  GO  TO  110 

TYPE 

54 

CALL  SEARCH 

TYPE 

55 

IF(ISRCH(2)  .EQ«  1)  CALL  E RROR ( 1 0 , NX T I 0) 

type 

56 

I , I) 


iF(rsRCM(n  ,eq*  ii  go  to  6? 

TYPF 

57 

C**  STORE  IN  SYMBOL  TABLE  IF  NOT  FOUND 

TYPE 

58 

lOTVPsl 

TYPE 

59 

CALL  STORE 

TYPE 

60 

LOC-NIO 

TYPE 

61 

C**  IF  PREVIOUSLY  TYPED*  ISSUE  DIAGNOSTIC 

TYPE 

6? 

6?  IF<BITGET(I0TBL<3,L0C)  .11,U  .NE.  0»  GO  TO 

120 

TYPE 

63 

IFiNtxnjPTRI  .NE.  LPAR>  GO  TO  67 

TYPE 

64 

C**  OI^CNSIONEO  VARIABLE 

TYPE 

65 

ISUB=1 

TYPE 

66 

IE*LOC 

TYPE 

67 

I=C 

type 

66 

68  I=U1 

TYPE 

69 

C**  GET  NEXT  DIMENSION 

TYPE 

70 

CALL  GNLE 

TYPE 

71 

IFUTYP  .NE.  S)  GO  TO  6S 

TYPE 

72 

C**  DIMENSION  IS  A CONSTANT,  CHECK  SUE 

TYPE 

73 

I0IM(  I » = N? 

TYPE 

74 

IF(N?  .GT.  .OR.  N?  .LE.  0)  CALL 

FRROR(8» 

TYPE 

75 

INCR- I NCR*N? 

TYPE 

76 

GO  TO  67 

type 

77 

65  IF(JTYP  .NE.  21  GO  TO  110 

TYPE 

78 

c»«  l/ARI«BLE  OIMENSrON,  STORE  IN  SYMBOL  TABLE  AMO  CHECK  VALIOITY 

TYPE 

79 

CALL  SEARCH 

type 

80 

IF<ISRCH(?»  .EO.  1)  CALL  E RROR M 0 , NX T I D) 

type 

81 

IF(ISRCH<1»  ,EQ.  1)  GO  TO  66 

TYPE 

62 

I0TYP*1 

Type 

83 

call  store 

type 

84 

LOCsNIO 

TYPF 

85 

66  IF  (0ITGET  < IOTBL  n,LOC»  ,12, 11  . NE  . 11  CALL 

FRR0R(9) 

Type 

86 

IF(BrTGET(I0TBL(3,L0C»  ,1,11  .NE,  0)  GO  TO 

130 

TYPE 

87 

C**  SET  TYPE  and  MAKE  SURE  IT  IS  INTEGER 

type 

88 

CALL  IMPTYP 

TYPE 

89 

IF(PITGETIIOTBL<3, LOO  ,10,31  .NE.  CALL 

FPR0R(9I 

type 

90 

lOTBL  13,LOC)s0lTPUT  aOT0H3,LOC)  , 1, 1 3) 

TYPE 

91 

IOIMins2**17fLOC 

TYPE 

92 

67  IF  (NEXT(  JPTRI  .EO.  COMMA)  GO  TO  68 

type 

93 

IF<AIJPTR-1)  .NE.  RPAP)  GO  TO  110 

TYPE 

94 

KsNEXT  <JPTRI 

TYPE 

95 

LOC=IE 

TYPE 

96 

C**  CHECK  THAT  variable  IS  NOT  PREVIOUSLY  OIMENSIOFCC 

TYPE 

97 

C**  SET  ••DIMENSIONED-  FLAG 

type 

98 

IFIBITGETdOTBLITiLOC)  .1.1)  .NE.  0)  CALL  ERROR  (1 1 . lOT  8L  M , LOC  1 ) 

TYPE 

99 

IOTBL<3,LOC>=6ITPUTaOT6M3,LOri  ,1,1) 

TYPE 

100 

IF«I  ,GT.  3)  GO  TO  110 

TYPE 

101 

IF(I-2I  85,80,75 

TYPE 

107 

C**  STORF  NO.  OF  DIMENSIONS  AND  OIMENSION  $ I ZE S 

IN  SYMBOL  table 

type 

103 

7 5 IDTBL  (I..L0C)  = B ITPUTl  IDTBL  lA.  LOC)  . lOIMI  3)  .36) 

TYPE 

104 

8 3 lOTBL  (A.LOC)  = B ITPUTUOTBl  ( A . L OC  ) . 10 1 M I ?)  ,18) 

TYPE 

105 

85  lnTBL<3,LOC)«alTPUT(IOTBL(3,LOC),IOIH(l)  ,36) 

type 

106 

TOTBL ( 3,LOC)=B ITPUTf IOTBL (3,L0C» ,1,7) 

TYPE 

107 

87  IF  (INCR  .EO.  1 > CO  TO  90 

type 

108 

IF (BITCE T( IOTBL (3 ,LOC) , 16, 1)  .NC.  1»  GO  TO 

90 

TYPE 

109 

C**  variable  in  COMMON,  RESET  COMMON  BLOCK  SIZE 

IF  NECFSSARY 

TYPE 

110 

COML OC=IDT0L(6,LOC) 

TYPE 

111 

IOTBL  (‘.,COHLOC»*  lOTRl  ( 4 , CO  ML  OC  ) ♦ I NCR- 1 

T YPE 

112 

C**  SET  -TYPE  SET-  FLAG  AND  STORF  TYPE  IN  SYMBOL 

T ABLE 

TYPE 

113 

90  IOTBL ( 3,LOC)sB ITPUT (IOTBL ( 1,LOC) , ISTATE, 10) 

TYPE 

114 

IOTBL (3,LOCI =B ITPUT ( IOTBL (3,L0C ) , 1, 11 ) 

TYPE 

115 

IF(A(JPTR-1)  ,EQ.  COMMA)  GO  TO  60 

type 

1 16 

IF  (NE  XT  ( JPTP)  .EO.  BLANK)  RETURN 

TYPE 

117 

110  call  ERR0R(7I 

TYPF 

Its 

RE  TURN 

type 

119 

120  CALL  EP70P(12,NXTI0) 

type 

170 

•?€  TUPN 

TYPE 

121 

130  CALL  ERROR(14,NXTIO) 

TYPE 

122 

PE  TURN 

type 

123 

END 

1 ■*  1 

TYPE 

124 

AuxJJ iary 
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Program  SESLIST 


PJ^OGRAH  SESLIST  (INPUT,  OUT  PUT,  TAPE5=  INPUT,  LIST  ,T  APE4*cISTl 
INTEGER  TYPE ,CLASS , BLKT Y P ( 10 0 > ,6LKSIZ (100> 

OINENSION  ISUBLT(2,a00) ,INTFAC(30Q) ,IARGS(?00> 

EQUIVALENCE  (BLKTYP ( 1) , lARGS(l) ),<aL<SIZ(l» ,I ARCS (101) ) 

NLIST=0 

IPTR=1 

1 REAO(S,S)  NAHc,NARGS, TYPE, CLASS, ISIZE 
5 F0RNAT(A6,1X,3I2,1X,I6) 

IFCISIZE  .LT.  1)  ISIZE=0 
IF  (EOF (S)  .NE,  0)  GO  TO  40 
NLISTsNLIST^l 
IVAR=0 

ISU8LT  (l,NLlSn  =NANE 
IF(NARGS  .EQ.  -1)  NARGS=IVAR=1 

ISU8LT(2,NLlSn s$HIFT(NARGS,54)  .OR.  ShI F T ( T YPE , % Z ) .OR. 

S SHIFT(CLASS,S0)  .or.  shift (ISIZE, 30) 

IF(NARGS  .EQ.  0)  GO  TO  1 

ISUBLT (Z,NLIST)=ISU0LT(2,NLIST)  .OR.  iPTR  .OR.  S H I FT ( I VAR , 46 ) 

IF(CLASS  .EO.  7}  GO  TO  2S 

jPTRsIPTR 

INCsl» (NARGS*1) /6 

IPTR=IPTR»INC 

NOPTR*IPTR- 1 

NPARAHs3*NARGS 

REAO(S,10)  (lARGS(I) ,1*1 ,NPARAN) 

10  FORMAT(20C3II,1X>) 

KOUNTsO 

00  20  IsJPTR,NOPTR 

INTFAC(I)»0 

NSHIFT»60 

DO  20  Ksl,ld 

XOUNT=KOUNT^l 

IF(K0UHT  .GT.  MPARAH)  GO  TO  1 
NShIFTaNSHIFT-3 

20  INTFAC( I) »INTFAC( I)  .OR.  SHI F T (I ARGF ( KOUNT ) , NSH I F T ) 

GO  TO  1 
25  JPTRsIPTR 

INCal^ (NARGS-1) /3 
IPTR«IPTR^INC 
NOPT  ft=IPTR-l 

READ (5, 27)  ( BL KSI Z ( 1 1 , BL K T YP ( I ) , I = 1 ,NARGS> 

27  FORNAT ( 10< 16, 1X,I1) ) 

KOUN  U 0 

00  30  I*JPTR,N0PTR 
INTFAC ( I) >0 
NSHIFT»60 
DO  30  <»l,3 
X0UNT=<0UNT ♦! 

IF(KOUNT  .G1.  NARGS)  GO  TO  1 
NSHIFT=NSHIFT-17 

1NTFAC(I)=INTFAC(I>  .OR.  SHi F T ( 8L KS I Z < KOUNT ) , NSH I F T ) 
NSHlFT*NSHlFT-3 

30  lNTFAC(T)aINTFAC(I)  .09.  SMI  FT ( 8L K T YP ( KOU NT ) , nSH I F T ) 

GO  TO  1 

40  MRITE(4)  NLIST,N0PTR 

WRITE (4)  ( ( ISU8LT (I,J),I«l,2),Jsl,NLIST) 

WRITE(4)  (INTFAC(l) ,I:l,NOPTR) 

PRINT  50,NLIST 

50  F0RHAT(////42X,*NFW  LIST  MAS  BEFN  CREATED  CONT A I N I MG* , l4 , • NAMES*) 
STOP 
END 
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DTNSRDC  ISSUES  THREE  TYPES  OF  REPORTS 

(1)  DTNSRDC  REPORTS,  A FORMAL  SERIES  PUBLISHING  INFORMATION  OF 
PERMANENT  TECHNICAL  VALUE,  DESIGNATED  BY  A SERIAL  REPORT  NUMBER 

(2)  DEPARTMENTAL  REPORTS,  A SEMIFORMAL  SERIES,  RECORDING  INFORMA 
TION  OF  A PRELIMINARY  OR  TEMPORARY  NATURE,  OR  OF  LIMITED  INTEREST  OR 
SIGNIFICANCE,  CARRYING  A DEPARTMENTAL  ALPHANUMERIC  IDENTIFICATION 

(3)  TECHNICAL  MEMORANDA,  AN  INFORMAL  SERIES,  USUALLY  INTERNAL 
WORKING  PAPERS  OR  DIRECT  REPORTS  TO  SPONSORS,  NUMBERED  AS  TM  SERIES 
REPORTS,  NOT  FOR  GENERAL  DISTRIBUTION. 


